neural network_program neural_simulator.txt

这是一个神经系统网络的代码

PROGRAM Neural_Simulator


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Neural Network in Fortran90
!! Multilayer Perceptron trained with
!! the backpropagation learning algorithm
!! coded in Fortran90 by Phil Brierley
!! www.philbrierley.com
!! this code may be used and modified at will
!! compiled using Compaq Visual Fortran
!!-------------------------------------------------------
!! This code reads in data from a csv text file
!! For the neural network training process follow
!! the code in the subroutine 'sTrain_Net'
!! most of the other code is for the data handling
!!-------------------------------------------------------
!! modifications recommended:
!!
!! 1)
!! The data is split into a train,test & validation set.
!! The final model weights should be the best on the test
!! set.
!!
!! 2)
!! The reported errors are based on the normalised data
!! values. These could be scaled up to give actual errors
!!
!!-------------------------------------------------------
!! prefix logic
!! a = array
!! i = integer 
!! r = real
!! l = logical
!! c = character
!! f = function
!! s = subroutine
!! g = global variable
!!-------------------------------------------------------
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!



!we must declare all our variables
IMPLICIT NONE

!-------------------------------------
!    declarations
!-------------------------------------

!used for checking user input from keyboard
!the value may be compiler dependent so is set here
INTEGER :: giIOERR_OK   =   0

!a handle on the opened source data file
INTEGER, PARAMETER :: giUNIT = 10

  
!-------------------------------------
!    declare arrays
!-------------------------------------

!data arrays
REAL,ALLOCATABLE :: garDataArray(:,:)
REAL,ALLOCATABLE :: garTrainingInputs(:,:),garTrainingOutputs(:)
REAL,ALLOCATABLE :: garTestingInputs(:,:),garTestingOutputs(:)
REAL,ALLOCATABLE :: garValidationInputs(:,:),garValidationOutputs(:)
REAL,ALLOCATABLE :: garInputs_this_pattern(:)

!weight arrays
REAL,ALLOCATABLE :: garWIH(:,:),garWIH_Best(:,:)
REAL,ALLOCATABLE :: garWHO(:),garWHO_Best(:)
!you might also want to save the best test set weights!


!neuron outputs
REAL,ALLOCATABLE :: garHVAL(:)

!dummy arays used in matrix multiplication
REAL,ALLOCATABLE :: garDUMMY1(:,:),garDUMMY2(:,:)

!max and min values of each field
!use these to scale up the reported errors
REAL,ALLOCATABLE :: garMaxInp(:),garMinInp(:)
REAL             :: grMaxOut, grMinOut



!-------------------------------------
!    declare other system variables
!-------------------------------------

!network topolgy numbering (dependent on number of hidden neurons)
INTEGER :: giNHS			!Number Hidden Start
INTEGER :: giNHF			!Number Hidden Finish
INTEGER :: giNOS			!Number Output Start

!general network numbering (independent of number of hidden neurons)
INTEGER :: giINPPB		!INPputs Plus Bias
INTEGER :: giINPUTS
INTEGER :: iOUTPUTS
INTEGER :: giNDU		!Number Data Units

!information about the source data file
INTEGER :: giDATAFIELDS, giFILEROWS, giSKIPLINES

!number of patterns
INTEGER :: giPATS,giTRAINPATS,giTESTPATS,giVALIDPATS

!errors
REAL    :: grRMSE,grRMSEBEST,grRMSETEST


!-------------------------------------
!    user set variables
!-------------------------------------

!number of hidden neurons
INTEGER :: giHIDDDEN
	
!number of epochs to train for
INTEGER :: giEPOCHS

!learning rates
REAL    :: grALR
REAL    :: grBLR

!how often progress is output to screen
INTEGER :: giREDISPLAY



!-------------------------------------
!   main routine
!-------------------------------------
	
	! setup	
	CALL sSetUp

	! neural network training
	CALL sTrain_Net(giIOERR_OK)
	PRINT *,'BYE!'

!-------------------------------------
!    end of main routine
!-------------------------------------




!-------------------------------------
!   all the functions and subroutines
!-------------------------------------

CONTAINS

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!   THE MAIN NEURAL NETWORK LEARNING SUBS       !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


SUBROUTINE sTrain_Net(iIOERR_OK)

INTEGER, INTENT(IN) ::	iIOERR_OK
INTEGER :: I,J,iPAT_NUM 
REAL    :: rOUTPUT_THIS_PAT, rOUTPRED, rER_THIS_PAT
REAL	:: rRAND


doLooping: DO  

	!get the number of epochs to train for or EXIT
	IF (.NOT. flGet_Number_Of_Epochs(giEPOCHS, iIOERR_OK)) EXIT

	!get the learning rates
	CALL fGet_Learning_Rates(grALR,grBLR,iIOERR_OK)

	!set how often the errors will be output to screen
	giREDISPLAY = fiGet_Screen_Output_Rate(iIOERR_OK)

	CALL sDisplay_Headers


	!do the required number of epochs
	doEpochs: DO J=1,giEPOCHS 

		!an epoch is when every pattern has been seen once
		doPats: DO I=1,giTRAINPATS  
			
			!! select a pattern at random
			CALL RANDOM_NUMBER(rRAND)
			iPAT_NUM=NINT(rRAND*(giTRAINPATS-1))+1

			!! set the data to this pattern
			garInputs_this_pattern(:)=garTrainingInputs(iPAT_NUM,:)
			rOUTPUT_THIS_PAT=garTrainingOutputs(iPAT_NUM)

			!! calculate the current error		
			rER_THIS_PAT= frCalc_Err_This_Pat &
			(garInputs_this_pattern,rOUTPUT_THIS_PAT,garWIH,garWHO)

			!! change weight hidden - output
			garWHO=garWHO-(grBLR*garHVAL*rER_THIS_PAT)

			!! change weight input - hidden 
			garDUMMY2(:,1)=garTrainingInputs(iPAT_NUM,:) 
			garDUMMY1(1,:)=rER_THIS_PAT*garWHO*(1-(garHVAL**2.00))
			garWIH=garWIH-(MATMUL(garDUMMY2,garDUMMY1)*grALR)

		ENDDO doPats ! one more epoch done


		!!  evaluate  'fitness' of of the network  after each epoch
		grRMSE = frCalculate_Error &
		(garTrainingInputs,garTrainingOutputs, garWIH, garWHO)

		!keep the new weights if an improvement has been made
		Call sKeep_Best_Weights(J)

		!! print errors to screen !!
		CALL sDisplay_Progress(J)


	ENDDO doEpochs
	
	! print final errors to screen
	CALL sDISPLAY_ERRORS
	
 ENDDO doLooping


END SUBROUTINE sTrain_Net



REAL FUNCTION frCalc_Err_This_Pat(arINPS_TP,rOUTPUT_TP,arWIHL,arWHOL)
! calculate the error on a specific pattern

	REAL,	DIMENSION(:),	INTENT(IN)	:: arINPS_TP
	REAL,	DIMENSION(:,:),	INTENT(IN)	:: arWIHL
	REAL,	DIMENSION(:),	INTENT(IN)	:: arWHOL
	REAL,	INTENT(IN)	:: rOUTPUT_TP

	REAL :: rOUTPREDL

	garHVAL=TANH(MATMUL(TRANSPOSE(arWIHL),arINPS_TP))
	garHVAL(UBOUND(garHVAL,1)) = 1
	rOUTPREDL=SUM(arWHOL*garHVAL)
	frCalc_Err_This_Pat =(rOUTPREDL-rOUTPUT_TP)


END FUNCTION frCalc_Err_This_Pat



REAL FUNCTION frCalculate_Error(arINPS,arOUT,arWIHL, arWHOL)
! calculate the overall error

	REAL, DIMENSION(:,:),	INTENT(IN)	:: arINPS
	REAL, DIMENSION(:),	INTENT(IN)	:: arOUT
	REAL, DIMENSION(:,:),	INTENT(INOUT)	:: arWIHL
	REAL, DIMENSION(:),	INTENT(INOUT)	:: arWHOL	

	REAL, DIMENSION(LBOUND(arINPS,2):UBOUND(arINPS,2))	:: arINPUTS_THIS_PAT
	REAL :: rSQERROR, rOUTPUT_THIS_PAT, rER_THIS_PAT

	INTEGER :: I,iLOWER,iUPPER

	iLOWER = LBOUND(arINPS,1)
	iUPPER = UBOUND(arINPS,1)

	! in this case the fitness function is the squared errors
	rSQERROR=0.0		

	DO I=iLOWER,iUPPER
		rOUTPUT_THIS_PAT = arOUT(I)
		arINPUTS_THIS_PAT(:)= arINPS(I,:)
		rER_THIS_PAT= frCalc_Err_This_Pat &
		(arINPUTS_THIS_PAT,rOUTPUT_THIS_PAT,arWIHL,arWHOL)
		rSQERROR=rSQERROR+(rER_THIS_PAT**2)
	ENDDO

	! root of the mean squared error
	frCalculate_Error=SQRT(rSQERROR/(iUPPER-iLOWER+1))	

END FUNCTION frCalculate_Error



SUBROUTINE sKEEP_BEST_WEIGHTS(iEpch)
! if the overall error has improved then keep the new weights

	INTEGER, INTENT(IN) :: iEpch

	!this will be on the first epoch
	IF (iEpch .EQ. 1) THEN
		grRMSEBEST = grRMSE
	ENDIF

	IF (grRMSE < grRMSEBEST) THEN
		garWIH_Best = garWIH
		garWHO_Best = garWHO
		grRMSEBEST = grRMSE
	ELSE
		garWIH = garWIH_Best
		garWHO = garWHO_Best
	ENDIF

END SUBROUTINE sKEEP_BEST_WEIGHTS





!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!  NON NEURAL SUBROUTINES AND FUNCTIONS !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE sSetUp

	CALL Random_Seed
	CALL sOpen_DataFile(giUNIT)
	CALL sScan_File(giUNIT,giDATAFIELDS, giFILEROWS, giSKIPLINES, giIOERR_OK)
	CALL sSet_Data_Constants(giPATS,giINPUTS,iOUTPUTS,giNDU,giINPPB, &
		giFILEROWS,giSKIPLINES,giDATAFIELDS)
	CALL sGet_Set_Sizes(giTRAINPATS,giTESTPATS,giVALIDPATS,giPATS, giIOERR_OK)
	CALL sAllocate_Data_Arrays
	CALL sRead_Data(giUNIT,giPATS,giNDU,garDataArray,giSKIPLINES,giIOERR_OK)
	CALL sCreate_Training_Data
	CALL sScale_Data
	CALL sSet_Weight_Constants(giIOERR_OK)
	CALL sAllocate_Weight_Arrays
	CALL sInitiate_Weights(garWIH,garWHO,garWIH_Best,garWHO_Best)

END SUBROUTINE sSetUp

!------------------
! Display
!------------------
SUBROUTINE sDisplay_Headers
!print to the screen

	IF (giTESTPATS > 0) THEN
		PRINT *,'epochs   TRAIN_error   TEST_error'
	ELSE
		PRINT *,'epochs   TRAIN_error'
	ENDIF

END SUBROUTINE sDisplay_Headers



SUBROUTINE sDisplay_Errors

	PRINT 100, frCalculate_Error &
	(garTrainingInputs,garTrainingOutputs, garWIH, garWHO)

	IF (giTESTPATS > 0) THEN 
		PRINT 110, frCalculate_Error &
		(garTestingInputs,garTestingOutputs,garWIH,garWHO)
	ENDIF

	IF (giVALIDPATS > 0) THEN
		PRINT 120, frCalculate_Error &
		(garValidationInputs,garValidationOutputs,garWIH,garWHO)
	ENDIF

100 FORMAT('TRAIN ERROR =',1X,F10.7)
110 FORMAT('TEST  ERROR =',1X,F10.7)
120 FORMAT('VAL   ERROR =',1X,F10.7)


END SUBROUTINE sDisplay_Errors



SUBROUTINE sDisplay_Progress(iEpch)

	INTEGER, INTENT(IN) :: iEpch

	IF ( (MODULO(iEpch,giREDISPLAY)==0) .OR. (iEpch==giEPOCHS) .OR. (iEpch==1) ) THEN
		IF (giTESTPATS > 0) THEN
			grRMSETEST = frCalculate_Error &
			(garTestingInputs,garTestingOutputs,garWIH, garWHO)
			PRINT 100,iEpch,grRMSEBEST,grRMSETEST
		ELSE
			PRINT 110,iEpch,grRMSEBEST
		ENDIF
	ENDIF

100 FORMAT(I5,4X,F10.7,4X,F10.7)
110 FORMAT(I5,4X,F10.7)

END SUBROUTINE sDisplay_Progress



!--------------------------
! input file handling
!--------------------------

INTEGER FUNCTION fiCount_Fields(iUNITNUMBER)
!count the number of fields by counting the delimiters	

	INTEGER, INTENT(IN)  :: iUNITNUMBER	
	CHARACTER (LEN = 20000):: miFIRSTLINE 

	READ(UNIT=iUNITNUMBER, FMT='(A)') miFIRSTLINE
	REWIND(UNIT=iUNITNUMBER)
	fiCount_Fields= fiCountF(',',TRIM(miFIRSTLINE)) + 1

END FUNCTION fiCount_Fields



INTEGER FUNCTION fiCountF(cLETTER, cSTRING)
! Count the number of occurrences of LETTER in STRING

	CHARACTER (1), INTENT(IN) :: cLETTER
	CHARACTER (*), INTENT(IN) :: cSTRING
	INTEGER :: I

	fiCountF = 0
	DO I = 1, LEN(cSTRING)
		IF (cSTRING(I:I) == cLETTER) fiCountF = fiCountF + 1
	END DO

END FUNCTION fiCountF



INTEGER FUNCTION fiCount_Rows(iUNITNUMBER)
!count the number of rows in the file

	INTEGER, INTENT(IN)  :: iUNITNUMBER	
 	CHARACTER (LEN = 3)  :: cALINE 

	REWIND(UNIT=iUNITNUMBER)

	fiCount_Rows= 0

	DO
	  READ(UNIT=iUNITNUMBER, FMT='(A)',END=100) cALINE

	  IF (TRIM(cALINE) .NE. '') THEN
		fiCount_Rows= fiCount_Rows + 1	
	  ELSE
		EXIT
	  ENDIF
		
	END DO
	
	100 CONTINUE
	  REWIND(UNIT=iUNITNUMBER)	

END FUNCTION fiCount_Rows



SUBROUTINE sOpen_DataFile(iUNITNUMBER)
! prompt user to enter data file name
	
	INTEGER, INTENT(IN) :: iUNITNUMBER
	CHARACTER*20000 cFILENAME

	CLOSE(iUNITNUMBER)

	PRINT *, 'Enter the datafile name'
	PRINT *, 'it must be comma delimited'
	PRINT *, 'with the the prediction variable in the last column.'
	PRINT *, 'If it is in the same folder as this executable just type the name'
	PRINT *, '?'

	DO 
		READ *, cFILENAME
		IF (cFILENAME == 'q' .or. cFILENAME == 'Q') STOP

		! open data file
		OPEN(UNIT=iUNITNUMBER, ERR=100, FILE=cFILENAME, STATUS='OLD')

		! File Opened OK so Exit
		EXIT

		! File not found
		100 PRINT *, 'Cannot find file ' // TRIM(cFILENAME) // &
		', re-enter or "Q" to quit'

	END DO

END SUBROUTINE sOpen_DataFile



SUBROUTINE sRead_Data &
(iUNITNUMBER, iPATTERNS, iFIELDS, arDATAARRAY, iHEADERROWS, iIOERR_OK)
! read in data	

	INTEGER, INTENT(IN)  :: iUNITNUMBER