* COMMON blocks for use with jetnet and nettra packages for NN analysis * written by Richard Hawkings (OPAL) and Alain Bellerive (SNO) * * NETTRA package for simple neural network training and analysis * based on JETNET. * PROGRAM NETTRA implicit none include 'netc.inc' include 'netp.inc' include 'netw.inc' include 'netch.inc' INTEGER NWPAWC,PAWCC PARAMETER (NWPAWC=2 000 000) COMMON/PAWC/PAWCC(NWPAWC) * INTEGER ISTAT,IC * * set up HBOOK and output histogram file CALL HLIMIT(NWPAWC) CALL HROPEN(20,'NETTRA','nettra.hb','N',1024,ISTAT) * NETTRA and user initialisation CALL NETINI * * read in and count the events CALL NETLOP(1) WRITE(*,1000) netc_nptot DO IC=1,netp_nclass netc_frac(IC)=netc_frac(IC)/netc_nptot WRITE(*,1010) IC,netc_frac(IC) ENDDO netc_npat(1)=netc_nptot*(1-netp_ftest) netc_npat(2)=netc_nptot-netc_npat(1) WRITE(*,1020) netc_npat * check cache status and enable if necessary IF (netp_scache) THEN WRITE(*,1030) netch_nevt,netcp_mxevt netp_ucache=.TRUE. ENDIF * perform network training CALL NETTRN * output summary CALL NETSUM * dump network state to jetnet format output file OPEN(21,FILE='nettra.jn') CALL JNDUMP(21) CLOSE(21) * CALL HCDIR('//NETTRA',' ') CALL HROUT(0,ISTAT,' ') CALL HREND('NETTRA') CLOSE(20) CALL UNFIN * 1000 FORMAT('Initialisation complete - total of',i7,' good patterns') 1010 FORMAT('Fraction in class',i2,':',f6.4) 1020 FORMAT('Training using',i7,' events, testing using',i7) 1030 FORMAT('Event cache filled with',I7,' events (space for',I7,')') END * SUBROUTINE NETINI implicit none include 'jncomm.inc' include 'netp.inc' include 'netc.inc' include 'netch.inc' INTEGER I,IO,ICL CHARACTER*40 CHTITL * * initialise FFREAD CALL FFINIT(0) * define FFREAD cards CALL FFKEY('CONFIG',netp_nlay,netp_maxl+1,'INTE') CALL FFKEY('NEPOCH',netp_nepoch,1,'INTE') CALL FFKEY('NCLASS',netp_nclass,1,'INTE') CALL FFKEY('NBINS',netc_nbin,1,'INTE') CALL FFKEY('NIBIN',netp_nib,1,'INTE') CALL FFKEY('LIBIN',netp_ibinl,2,'REAL') CALL FFKEY('FTEST',netp_ftest,1,'REAL') CALL FFKEY('EVENTS',netp_maxevt,1,'INTE') CALL FFKEY('CACHE',netp_scache,1,'LOGI') CALL FFKEY('NORM',netp_norm,1,'LOGI') CALL FFKEY('MASK',netp_mask,netp_maxi,'LOGI') * set up some defaults netp_ftest=0.25 netp_nepoch=10 netp_nlay=3 netp_nnlay(1)=3 netp_nnlay(2)=4 netp_nnlay(3)=1 netp_nnlay(4)=1 netp_nclass=2 netp_maxevt=0 netp_ucache=.FALSE. netp_scache=.FALSE. netch_nevt=0 netp_norm=.FALSE. netc_nbin=50 netp_nib=60 netp_ibinl(1)=-0.1 netp_ibinl(2)=1.1 netp_ismask=.FALSE. DO I=1,netp_maxi netp_mask(I)=.FALSE. ENDDO * netc_nptot=0 CALL VZERO(netc_frac,netc_mclass) * do user initialisation and parameter setting CALL UNINIT * read FF cards CALL FFGO * make some size checks IF (netp_nclass.GT.netc_mclass) WRITE(*,1020) netp_nclass IF (netc_nbin.GT.netc_mbin) WRITE(*,1030) netc_nbin * now set up the neural net structure in JETNET common MSTJN(1)=netp_nlay DO I=1,netp_nlay MSTJN(9+I)=netp_nnlay(I) ENDDO netp_nop=MSTJN(9+MSTJN(1)) * setup jetnet 3.1 parameters MSTJN(5)=0 ! standard updating MSTJN(3)=1 ! sigmoid function 1/(1+exp(-2x)) PARJN(4)=0.5 ! width of weights * initialise network CALL JNINIT * set parameters for updating PARJN(1)=0.5 ! initial learning rate PARJN(2)=0.5 ! momentum parameter PARJN(11)=0.99 ! decrease in scale factor per epoch * some printout of options WRITE(*,1000) netp_nclass,netp_nepoch,netc_nbin IF (netp_maxevt.NE.0) WRITE(*,1010) netp_maxevt DO I=1,netp_maxi IF (netp_mask(I)) THEN netp_ismask=.TRUE. WRITE(*,1050) I ENDIF ENDDO * booking of histograms DO IO=1,netp_nop WRITE(CHTITL,1100) IO CALL HBOOK1(9+IO,CHTITL,netp_nepoch,0.5,netp_nepoch+0.5,0.) WRITE(CHTITL,1110) IO CALL HBOOK1(19+IO,CHTITL,netp_nepoch,0.5,netp_nepoch+0.5,0.) WRITE(CHTITL,1120) IO CALL HBOOk1(29+IO,CHTITL,netc_nbin,0.,1.,0.) WRITE(CHTITL,1130) IO CALL HBOOK1(39+IO,CHTITL,netc_nbin,0.,1.,0.) DO ICL=1,netp_nclass WRITE(CHTITL,1140) IO,ICL CALL HBOOK1(89+10*ICL+IO,CHTITL,netc_nbin,0.,1.,0.) WRITE(CHTITL,1150) IO,ICL CALL HBOOK1(189+10*ICL+IO,CHTITL,netc_nbin,0.,1.,0.) ENDDO ENDDO DO ICL=1,netp_nclass DO IO=1,netp_nnlay(1) WRITE(CHTITL,1160) IO,ICL CALL HBOOK1(199+IO+100*ICL,CHTITL, + netp_nib,netp_ibinl(1),netp_ibinl(2),0.) ENDDO ENDDO * check cache parameters are sensible, if used IF (netp_scache) THEN IF (netcp_ninp.LT.netp_nnlay(1).OR.netcp_nout.LT.netp_nop) THEN WRITE(*,1200) netp_scache=.FALSE. ENDIF ENDIF * user final setup and parameter alteration CALL UNSETR * 1000 FORMAT('Training using',i2,' event classes over',i6, + ' epochs with',i4,' bins') 1010 FORMAT('Only using',i7,' events of the data sample') 1020 FORMAT('ERROR: Number of classes too big:',i4) 1030 FORMAT('ERROR: Number of bins too big:',i4) 1040 FORMAT('Setup with',i3,' classes and',i4,' bins') 1050 FORMAT('Input',i4,' will be masked (set to 0)') 1100 FORMAT('[c] vs. epoch output',i2,' (train)') 1110 FORMAT('[c] vs. epoch output',i2,' (test)') 1120 FORMAT('Purity vs output',i2,' (train)') 1130 FORMAT('Purity vs output',i2,' (test)') 1140 FORMAT('Output',i2,' class',i2,' (train)') 1150 FORMAT('Output',i2,' class',i2,' (test)') 1160 FORMAT('Input',i3,' class',i2) 1200 FORMAT('Not enough space in cache for input or output size!') END * SUBROUTINE NETLOP(ICODE) * loop over all the events * ICODE=1 : count them * ICODE=2 : perform one train/test cycle * implicit none INTEGER ICODE include 'netp.inc' include 'netc.inc' include 'netw.inc' include 'netch.inc' include 'jncomm.inc' INTEGER ISEQ,ISUB,NSUB,I LOGICAL LFIN,LSEL * ISEQ=0 netw_ievt=0 10 CONTINUE * attempt to get an event LFIN=.FALSE. ISEQ=ISEQ+1 IF (netp_ucache) THEN * get an event directly from the cache LFIN=(ISEQ.GT.netch_nevt) IF (.NOT.LFIN) THEN DO I=1,netcp_ninp OIN(I)=netch_oin(I,ISEQ) ENDDO DO I=1,netcp_nout OUT(I)=netch_out(I,ISEQ) ENDDO CALL NETEVT(ICODE) ENDIF ELSE * get event(s) from the user CALL UNPATN(ISEQ,NSUB,LSEL,LFIN) IF (.NOT.LFIN) THEN * not the end of the events - simple single event IF(NSUB.EQ.-1.AND.LSEL) CALL NETEVT(ICODE) * or multiple sub events IF(NSUB.GT.0.AND.LSEL) THEN DO ISUB=1,NSUB CALL UNPATS(ISUB,LSEL) IF(LSEL) CALL NETEVT(ICODE) ENDDO ENDIF ENDIF ENDIF * try to get another event? IF (.NOT.LFIN.AND. + (netw_ievt.LT.netp_maxevt.OR.netp_maxevt.EQ.0)) GOTO 10 END * SUBROUTINE NETEVT(ICODE) * process an event in the jetnet common according to ICODE implicit none INTEGER ICODE include 'netp.inc' include 'netc.inc' include 'netw.inc' include 'netch.inc' include 'jncomm.inc' INTEGER ICL,ISAM,IB,I REAL S INTEGER MAXRZE EXTERNAL MAXRZE * netw_ievt=netw_ievt+1 * save the event in cache if neccessary IF (netp_scache.AND..NOT.netp_ucache) THEN * first check for space in cache IF (netch_nevt.LT.netcp_mxevt) THEN netch_nevt=netch_nevt+1 DO I=1,netcp_ninp netch_oin(I,netch_nevt)=OIN(I) ENDDO DO I=1,netcp_nout netch_out(I,netch_nevt)=OUT(I) ENDDO ELSE * no space - turn off cache mode WRITE(*,1000) netcp_mxevt netp_scache=.FALSE. ENDIF ENDIF * classify the event - single and multiple net outputs IF (netp_nop.EQ.1) THEN ICL=NINT((netp_nclass-1)*OUT(1))+1 ELSE ICL=MAXRZE(OUT,MSTJN(9+MSTJN(1))) ENDIF IF (ICL.LT.1) ICL=1 IF (ICL.GT.netp_nclass) ICL=netp_nclass * mask any inputs if needed IF (netp_ismask) THEN DO I=1,netp_nnlay(1) IF (netp_mask(I)) OIN(I)=0. ENDDO ENDIF * * do the appropriate processing IF (ICODE.EQ.1) THEN * event counting phase netc_frac(ICL)=netc_frac(ICL)+1 netc_nptot=netc_nptot+1 ELSE IF (ICODE.EQ.2) THEN * training/testing phase IF (netw_ievt.LE.netc_npat(1)) THEN * use pattern for training ISAM=1 CALL JNTRAL ELSE * use pattern for testing ISAM=2 CALL JNTEST ENDIF * apply normalisation transformation to o/p if multiple nodes IF (netp_nop.GT.1.AND.netp_norm) THEN S=0. DO I=1,netp_nop S=S+OUT(I) ENDDO DO I=1,netp_nop OUT(I)=OUT(I)/S ENDDO ENDIF * increment the appropriate histogram bin(s) DO IB=1,netp_nop I=1+netc_nbin*OUT(IB) IF (I.LT.1) I=1 IF (I.GT.netc_nbin) I=netc_nbin netc_nent(I,ICL,IB,ISAM)=netc_nent(I,ICL,IB,ISAM)+1 ENDDO IF (netp_lepoch) THEN * fill input/output histograms on last call DO I=1,netp_nnlay(1) CALL HFILL(199+100*ICL+I,OIN(I),0.,1.) ENDDO DO I=1,netp_nop CALL HFILL(-11+100*ISAM+10*ICL+I,OUT(I),0.,1.) ENDDO ENDIF ENDIF 1000 FORMAT('Exceeded cache store of ',i7,' events, cache DISABLED') END * SUBROUTINE NETTRN * perform network training and testing implicit none include 'netp.inc' include 'netc.inc' INTEGER IP,ISAM,ICL,IO,I,IB,NBIN REAL F,EF,NB,NG * DO IP=1,netp_nepoch netp_lepoch=(IP.EQ.netp_nepoch) CALL VZERO(netc_nent, + netc_mbin*netc_mclass*netc_mclass*netc_nsam) * loop over all events CALL NETLOP(2) * calculate figures of merit for training and testing samples DO ISAM=1,2 * loop over all outputs DO IO=1,netp_nop F=0. EF=0. NBIN=0 * loop over all bins DO IB=1,netc_nbin * count the number of good and bad events in this bin IF (netp_nop.EQ.1) THEN ICL=2 NG=netc_nent(IB,2,1,ISAM) NB=netc_nent(IB,1,1,ISAM) ELSE ICL=IO NB=0 DO I=1,netp_nclass IF (I.EQ.IO) THEN NG=netc_nent(IB,I,IO,ISAM) ELSE NB=NB+netc_nent(IB,I,IO,ISAM) ENDIF ENDDO ENDIF * increment the sums for this bin IF (NG+NB.GT.0) THEN F=F+(((1-netc_frac(ICL))*NG-netc_frac(ICL)*NB)**2)/ + (NG+NB) EF=EF+NG*NB* + ((netc_frac(ICL)*NG-(1-netc_frac(ICL))*NB)**2)/ + (NG+NB)**3 NBIN=NBIN+1 ENDIF ENDDO * derive the figure of merit and error netc_f(IO,ISAM)=-REAL(NBIN)/REAL(netc_npat(ISAM))+ + F/(netc_frac(ICL)*(1-netc_frac(ICL))*netc_npat(ISAM)) netc_sf(IO,ISAM)=SQRT(EF)/ + (netc_frac(ICL)*(1-netc_frac(ICL))*netc_npat(ISAM)) netc_fmepoch(IP,ISAM)=netc_f(IO,ISAM) netc_efmepoch(IP,ISAM)=netc_sf(IO,ISAM) C CALL HFILL(IO+10*ISAM-1,REAL(IP),0.,netc_f(IO,ISAM)) ENDDO ENDDO WRITE(*,1000) IP,(netc_f(I,1),netc_sf(I,1),I=1,netp_nop) WRITE(*,1010) (netc_f(I,2),netc_sf(I,2),I=1,netp_nop) ENDDO * 1000 FORMAT('After',i4,' epochs, trainFoM=',4(f6.4,'+-',f6.4,1x)) 1010 FORMAT(18x,'test FoM=',4(f6.4,'+-',f6.4,1x)) END * SUBROUTINE NETSUM * output summary of FoM for each input and output * also fill the purity histograms implicit none include 'netp.inc' include 'netc.inc' INTEGER IO,ISAM,ICL,I,IB,NBIN REAL F,EF,NG,NB REAL HI,P(netc_mbin),EP(netc_mbin) EXTERNAL HI * * fill the purity histograms for each sample and output DO ISAM=1,2 DO IO=1,netp_nop DO IB=1,netc_nbin IF (netp_nop.EQ.1) THEN NG=HI(10+100*ISAM,IB) NB=HI(100*ISAM,IB) ELSE NB=0 DO ICL=1,netp_nclass IF (ICL.EQ.IO) THEN NG=HI(100*ISAM+ICL*10-10,IB) ELSE NB=NB+HI(100*ISAM+ICL*10-10,IB) ENDIF ENDDO ENDIF IF (NB+NG.GT.0) THEN P(IB)=NG/(NG+NB) EP(IB)=SQRT(NG*(1-P(IB)))/(NG+NB) ELSE P(IB)=0. EP(IB)=0. ENDIF ENDDO CALL HPAK(19+10*ISAM+IO,P) CALL HPAKE(19+10*ISAM+IO,EP) ENDDO * and the figure of merit vs epoch CALL HPAK(ISAM*10,netc_fmepoch(1,ISAM)) CALL HPAKE(ISAM*10,netc_efmepoch(1,ISAM)) ENDDO WRITE(*,1000) * compute and print the FoM for each input DO IO=1,netp_nnlay(1) DO ICL=1,netp_nclass F=0 EF=0 NBIN=0 * note HI() returns underflow and overflow bins at edge of range DO IB=0,netp_nib+1 NB=0 DO I=1,netp_nclass IF (I.EQ.ICL) THEN NG=HI(199+IO+I*100,IB) ELSE NB=NB+HI(199+IO+I*100,IB) ENDIF ENDDO IF (NB+NG.GT.0) THEN F=F+(((1-netc_frac(ICL))*NG-netc_frac(ICL)*NB)**2)/ + (NG+NB) EF=EF+NG*NB* + ((netc_frac(ICL)*NG-(1-netc_frac(ICL))*NB)**2)/(NG+NB)**3 NBIN=NBIN+1 ENDIF ENDDO F=-REAL(NBIN)/REAL(netc_nptot)+ + F/(netc_frac(ICL)*(1-netc_frac(ICL))*netc_nptot) EF=SQRT(EF)/(netc_frac(ICL)*(1-netc_frac(ICL))*netc_nptot) WRITE(*,1010) IO,ICL,F,EF ENDDO ENDDO * WRITE(*,1020) DO IO=1,netp_nop WRITE(*,1030) IO,(netc_f(IO,ISAM),netc_sf(IO,ISAM),ISAM=1,2) ENDDO * 1000 FORMAT('NETTRA finished - summary'/ + 'Nodename FoM +- error') 1010 FORMAT('Input',i3,' class',i2,2x,f6.4,'+-',f6.4) 1020 FORMAT(7x,'trainFoM +- error testFoM +-error') 1030 FORMAT('Output',i2,2(2x,f6.4,'+-',f6.4)) END