neural network_program neural_simulator.txt

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

	INTEGER, INTENT(IN)  :: iPATTERNS
	INTEGER, INTENT(IN)  :: iFIELDS
	INTEGER, INTENT(IN)  :: iHEADERROWS
	INTEGER, INTENT(IN)  :: iIOERR_OK
	REAL, INTENT(OUT)    :: arDATAARRAY(iPATTERNS,iFIELDS)

	CHARACTER (LEN = 1)  :: cHEAD	
	
	INTEGER :: I,K
	INTEGER :: mis

	REWIND(UNIT=iUNITNUMBER)
	
	IF (iHEADERROWS > 0) THEN	
		DO I = 1,iHEADERROWS
			READ(UNIT=iUNITNUMBER, FMT='(A)',END=100) cHEAD
		ENDDO
		100 IF (I < iHEADERROWS) PRINT *,'Too many header rows...' 
	END IF	
	
	PRINT *, ' Reading data...'
	
	DO I=1,iPATTERNS
		READ(UNIT=iUNITNUMBER, FMT=*,iostat=mis, END=200)(arDATAARRAY(I,K),K=1,iFIELDS)
		IF(mis /= iIOERR_OK) then
		  PRINT *, 'Invalid data on line ', i + iHEADERROWS
		  STOP
		ENDIF
	ENDDO
	
	PRINT *, ' Data read OK!'

	200 IF (I < iPATTERNS) PRINT *,'Too many header rows...'

	CLOSE(iUNITNUMBER)

END SUBROUTINE sRead_Data



SUBROUTINE sScan_File(iUNITNUMBER, iDATAFIELDS, iFILEROWS, iSKIPLINES, iIOERR_OK)

	INTEGER, INTENT(IN)   :: iUNITNUMBER	
	INTEGER, INTENT(OUT)  :: iDATAFIELDS
	INTEGER, INTENT(OUT)  :: iFILEROWS
	INTEGER, INTENT(OUT)  :: iSKIPLINES
	INTEGER, INTENT(INOUT)   :: iIOERR_OK	

	PRINT *, 'Scanning file...'

	REWIND(UNIT=iUNITNUMBER)

	iDATAFIELDS = fiCount_Fields(iUNITNUMBER)
	iFILEROWS = fiCount_Rows(iUNITNUMBER)

	PRINT * , 'Fields = ',iDATAFIELDS
	PRINT * , 'Rows   = ',iFileRows

	DO
	  iSKIPLINES = fiGet_Header_Rows(iIOERR_OK)
		IF (iSKIPLINES < iFILEROWS) THEN
			EXIT
		ELSE
			PRINT *, 'You have more header rows than &
			there are rows in the data!'
		ENDIF
	END DO

END SUBROUTINE sScan_File



INTEGER FUNCTION fiGet_Header_Rows(iIOERR_OK)

	INTEGER, INTENT(IN)		:: iIOERR_OK
	INTEGER :: I

	DO
	 WRITE(*,'(A)',advance='no',iostat=I) 'How many header rows in the file?'
	 IF(I /= iIOERR_OK) EXIT
		READ(*,*,iostat=I) fiGet_Header_Rows
		IF(I /= iIOERR_OK) CYCLE
		IF (fiGet_Header_Rows< 0) THEN
		 PRINT *, 'OK - no header row...'
		 fiGet_Header_Rows= 0
		ENDIF
	 EXIT
	ENDDO

END FUNCTION fiGet_Header_Rows


!---------------------------
! getting user input
!---------------------------
INTEGER FUNCTION fiGet_Hidden_Neurons(iIOERR_OK)

	INTEGER, INTENT(IN)		:: iIOERR_OK
	INTEGER :: I

	DO
	 WRITE(*,'(A)',advance='no',iostat=I) 'How many hidden neurons?'
	 IF(I /= iIOERR_OK) EXIT
		READ(*,*,iostat=I) fiGet_Hidden_Neurons
		IF(I /= iIOERR_OK) CYCLE
		IF (fiGet_Hidden_Neurons< 1) THEN
		 PRINT *, 'Hidden neurons set to 1'
		 fiGet_Hidden_Neurons = 1
		ENDIF
	 EXIT
	ENDDO

END FUNCTION fiGet_Hidden_Neurons



SUBROUTINE sGet_Set_Sizes(iTRAIN,iTEST,iVALID,iTOTAL,iIOERR_OK)

	INTEGER, INTENT(IN)	:: iIOERR_OK, iTOTAL
	INTEGER, INTENT(OUT)	:: iTRAIN, iTEST, iVALID

	INTEGER	:: I, iPERCTR, iPERCTE

	iTRAIN = iTOTAL
	iTEST = 0
	iVALID = 0
	iPERCTR = 33
	iPERCTE = 0

	DO
		iPERCTR = 33
		WRITE(*,'(A)',advance='no',iostat=I) &
		'What percent do you want to use for the training sample? '

		IF(I /= iIOERR_OK) EXIT
		READ(*,*,iostat=I) iPERCTR
		IF(I /= iIOERR_OK) CYCLE

		IF (iPERCTR >= 100) THEN
			PRINT *, 'OK - all the data will be used for training...'
			iPERCTR = 100
		ENDIF

		IF (iPERCTR<33) THEN
			PRINT *, 'We will use 33%...'
			iPERCTR = 33
		ENDIF

		iTRAIN = iTOTAL * iPERCTR / 100

		EXIT

	ENDDO


	IF (iPERCTR < 100) THEN

	 DO

		WRITE(*,'(A)',advance='no',iostat=I) &
		'What percent do you want to use for the testing sample? '

		IF(I /= iIOERR_OK) EXIT
		READ(*,*,iostat=I) iPERCTE
		IF(I /= iIOERR_OK) CYCLE

		IF (iPERCTE>100-iPERCTR) CYCLE
		IF (iPERCTE<=0) CYCLE

		iTEST = iTOTAL * iPERCTE / 100
		IF (iTEST<1) iTEST = 1

		EXIT

	 ENDDO

	ENDIF


	iVALID = iTOTAL - iTRAIN - iTEST
	PRINT * , ' '
	PRINT * , ' ' 
	PRINT 100 ,iTOTAL
	PRINT 110 ,iPERCTR,iTRAIN
	PRINT 120 ,iPERCTE,iTEST
	PRINT 130 ,100-iPERCTR-iPERCTE,iVALID
	PRINT * , '' 

100 FORMAT ('Total patterns = ',I10)
110 FORMAT ('Train =',1X,I3,'%',I7,1X,'Patterns')
120 FORMAT ('Test  =',1X,I3,'%',I7,1X,'Patterns')
130 FORMAT ('Valid =',1X,I3,'%',I7,1X,'Patterns')

END SUBROUTINE sGet_Set_Sizes



LOGICAL FUNCTION flGet_Number_Of_Epochs(iEPOCHS, iIOERR_OK)

	INTEGER, INTENT(OUT)	:: iEPOCHS
	INTEGER, INTENT(IN)	:: iIOERR_OK
	INTEGER			:: i

	DO

	 WRITE(*,'(A)',advance='no',iostat=i) &
	 'How many epochs to train for (0 to exit) ?'

	 IF(i /= iIOERR_OK) EXIT
		READ(*,*,iostat=i) iEPOCHS
		IF(i /= iIOERR_OK) CYCLE

	 IF (iEPOCHS <= 0) THEN
		flGet_Number_Of_Epochs = .FALSE.
	 ELSE
		flGet_Number_Of_Epochs = .TRUE.
	 ENDIF	
	
	 EXIT

	ENDDO


END FUNCTION flGet_Number_Of_Epochs



SUBROUTINE fGet_Learning_Rates(ra,rb, iIOERR_OK)

	REAL, INTENT(OUT)	:: ra
	REAL, INTENT(OUT)	:: rb
	INTEGER, INTENT(IN)	:: iIOERR_OK
	INTEGER			:: I

	DO
	 WRITE(*,'(A)',advance='no',iostat=I) 'Learning Rate (>0 - 2) ?'
	 IF(I /= iIOERR_OK) EXIT
	 READ(*,*,iostat=I) ra
	 IF(i /= iIOERR_OK) CYCLE
	 rb = ra/10
	 EXIT
	ENDDO

END SUBROUTINE fGet_Learning_Rates



INTEGER FUNCTION fiGet_Screen_Output_Rate(iIOERR_OK) 

	INTEGER, INTENT(IN)	:: iIOERR_OK
	INTEGER			:: I

	DO
	 WRITE(*,'(A)',advance='no',iostat=I) 'Screen Output Rate (whole number)?'

	 IF(I /= iIOERR_OK) EXIT
		READ(*,*,iostat=I) fiGet_Screen_Output_Rate 
		IF(I /= iIOERR_OK) CYCLE

	 IF (fiGet_Screen_Output_Rate < 1) THEN
		fiGet_Screen_Output_Rate = 1
		PRINT *, 'OK - set it to 1!'
	 ENDIF	

	 EXIT
	ENDDO

END FUNCTION fiGet_Screen_Output_Rate



!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! DATA ALLOCATION SUBROUTINES AND FUNCTIONS   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE sAllocate_Data_Arrays()

	! set the array dimensions
	ALLOCATE(garDataArray(giPATS,giNDU)) !raw data read from file
	ALLOCATE(garTrainingInputs(giTRAINPATS,giINPPB)) !input patterns
	ALLOCATE(garTrainingOutputs(giTRAINPATS)) !output
	ALLOCATE(garTestingInputs(giTESTPATS,giINPPB)) !input patterns
	ALLOCATE(garTestingOutputs(giTESTPATS)) !output
	ALLOCATE(garValidationInputs(giVALIDPATS,giINPPB)) !input patterns
	ALLOCATE(garValidationOutputs(giVALIDPATS)) !output
	ALLOCATE(garInputs_this_pattern(giINPPB)) !pattern being presented
	ALLOCATE(garMaxInp(giINPPB))
	ALLOCATE(garMinInp(giINPPB))

END SUBROUTINE sAllocate_Data_Arrays



SUBROUTINE sAllocate_Weight_Arrays()

	ALLOCATE(garWIH(giINPPB,giNHS:giNHF))		!input-hidden weights
	ALLOCATE(garWIH_Best(giINPPB,giNHS:giNHF))	!best weights
	ALLOCATE(garWHO(giNHS:giNHF))			!hidden-output weights
	ALLOCATE(garWHO_Best(giNHS:giNHF))		!best weights
	ALLOCATE(garHVAL(giNHS:giNHF))			!hidden neuron outputs
	ALLOCATE(garDUMMY1(1,giNHS:giNHF))		!dummy matrix
	ALLOCATE(garDUMMY2(giINPPB,1))			!dummy matrix

END SUBROUTINE sAllocate_Weight_Arrays



SUBROUTINE sSet_Data_Constants &
	(iNPATS,iINPUTS,iNOUTPUTS,iNDU,iINPPB,iFILEROWS,iSKIPLINES,iDATAFIELDS)

	INTEGER, INTENT (OUT)	:: iNPATS
	INTEGER, INTENT (OUT)	:: iINPUTS
	INTEGER, INTENT (OUT)	:: iNOUTPUTS
	INTEGER, INTENT (OUT)	:: iNDU
	INTEGER, INTENT (OUT)	:: iINPPB
	
	INTEGER, INTENT (IN)	:: iFILEROWS
	INTEGER, INTENT (IN)	:: iSKIPLINES	
	INTEGER, INTENT (IN)	:: iDATAFIELDS 


	iNPATS = iFILEROWS - iSKIPLINES
	iINPUTS = iDATAFIELDS - 1
	iNOUTPUTS=1			! number of outputs (fixed)
	iNDU=iINPUTS+iNOUTPUTS		!Number Data Units
	iINPPB=iINPUTS+1		!INPut Plus Bias


END SUBROUTINE sSet_Data_Constants



SUBROUTINE sSet_Weight_Constants(iIOERR_OK)

	INTEGER, INTENT(IN) :: iIOERR_OK

	giHIDDDEN = fiGet_Hidden_Neurons(iIOERR_OK)  

	! number the neurons
	giHIDDDEN=giHIDDDEN+1			!accounts for bias to output
	giNHS=giINPPB+1				!Number Hidden Start
	giNHF=giINPPB+giHIDDDEN			!Number Hidden Finish
	giNOS=giNHF+1				!Number Output Start

END SUBROUTINE sSet_Weight_Constants



SUBROUTINE sCreate_Training_Data()
! create train, test and validation sets

	INTEGER :: iTRAINCOUNT,iTESTCOUNT,iVALIDCOUNT
	INTEGER :: I
	REAL :: rTRPC,rTEPC
	REAL :: rRAND	
	
	rTRPC = FLOAT(giTRAINPATS) / FLOAT(giPATS)
	rTEPC = rTRPC + (FLOAT(giTESTPATS) / FLOAT(giPATS))
	
	iTRAINCOUNT = 0
	iTESTCOUNT = 0
	iVALIDCOUNT = 0

	PRINT *, ' Allocating data...'

 DO I=1,giPATS
	CALL RANDOM_NUMBER(rRAND)

	IF ((rRAND <= rTRPC) .AND. (iTRAINCOUNT < giTRAINPATS)) THEN
		iTRAINCOUNT = iTRAINCOUNT + 1 
		garTrainingInputs(iTRAINCOUNT,1:giINPUTS)=garDataArray(I,1:giINPUTS)
		garTrainingInputs(iTRAINCOUNT,giINPPB)=1
		garTrainingOutputs(iTRAINCOUNT)=garDataArray(I,giNDU)

	ELSEIF ((rRAND <= rTEPC) .AND. (iTESTCOUNT < giTESTPATS)) THEN
		iTESTCOUNT = iTESTCOUNT + 1
		garTestingInputs(iTESTCOUNT,1:giINPUTS)=garDataArray(I,1:giINPUTS)
		garTestingInputs(iTESTCOUNT,giINPPB)=1
		garTestingOutputs(iTESTCOUNT)=garDataArray(I,giNDU)

	ELSEIF ((rRAND > rTEPC) .AND. (iVALIDCOUNT < giVALIDPATS)) THEN
		iVALIDCOUNT = iVALIDCOUNT + 1
		garValidationInputs(iVALIDCOUNT,1:giINPUTS)=garDataArray(I,1:giINPUTS)
		garValidationInputs(iVALIDCOUNT,giINPPB)=1
		garValidationOutputs(iVALIDCOUNT)=garDataArray(I,giNDU)

	ELSEIF (iTRAINCOUNT < giTRAINPATS) THEN
		iTRAINCOUNT = iTRAINCOUNT + 1 
		garTrainingInputs(iTRAINCOUNT,1:giINPUTS)=garDataArray(I,1:giINPUTS)
		garTrainingInputs(iTRAINCOUNT,giINPPB)=1
		garTrainingOutputs(iTRAINCOUNT)=garDataArray(I,giNDU)

	ELSEIF (iTESTCOUNT < giTESTPATS) THEN
		iTESTCOUNT = iTESTCOUNT + 1
		garTestingInputs(iTESTCOUNT,1:giINPUTS)=garDataArray(I,1:giINPUTS)
		garTestingInputs(iTESTCOUNT,giINPPB)=1
		garTestingOutputs(iTESTCOUNT)=garDataArray(I,giNDU)

	ELSEIF (iVALIDCOUNT < giVALIDPATS) THEN
		iVALIDCOUNT = iVALIDCOUNT + 1
		garValidationInputs(iVALIDCOUNT,1:giINPUTS)=garDataArray(I,1:giINPUTS)
		garValidationInputs(iVALIDCOUNT,giINPPB)=1
		garValidationOutputs(iVALIDCOUNT)=garDataArray(I,giNDU)

	ENDIF

 ENDDO

	!the array 'data' is no longer required
	DEALLOCATE(garDataArray)				
	PRINT *, ' Data allocated OK!'

END SUBROUTINE sCreate_Training_Data




SUBROUTINE sScale_Data()
! scale the data

	INTEGER :: I

	PRINT *, ' Normalising data...'

	! find the max and min values
	garMaxInp(:) = MAXVAL(garTrainingInputs,1)
	garMinInp(:) = MINVAL(garTrainingInputs,1)
	grMaxOut = MAXVAL(garTrainingOutputs)
	grMinOut = MINVAL(garTrainingOutputs)


	! need to check if max = min

	! scale between -1 and 1
	DO i = 1,giTRAINPATS
	garTrainingInputs(i,1:giINPUTS) = &
	((garTrainingInputs(i,1:giINPUTS) - garMinInp(1:giINPUTS)) / &
	(garMaxInp(1:giINPUTS) - garMinInp(1:giINPUTS)) - 0.5) * 2
	ENDDO	

	garTrainingOutputs(:) = &
	((garTrainingOutputs(:) - grMinOut) / (grMaxOut - grMinOut) - 0.5) * 2
	
	IF (giTESTPATS > 0) THEN
	DO i = 1,giTESTPATS
	garTestingInputs(i,1:giINPUTS) = &
	((garTestingInputs(i,1:giINPUTS) - garMinInp(1:giINPUTS)) / &
	(garMaxInp(1:giINPUTS) - garMinInp(1:giINPUTS)) - 0.5) * 2
	ENDDO		
	garTestingOutputs(:) = &
	((garTestingOutputs(:) - grMinOut) / (grMaxOut - grMinOut) - 0.5) * 2
	ENDIF

	IF (giVALIDPATS > 0) THEN
	DO i = 1,giVALIDPATS
	garValidationInputs(i,1:giINPUTS) = &
	((garValidationInputs(i,1:giINPUTS) - garMinInp(1:giINPUTS)) / &
	(garMaxInp(1:giINPUTS) - garMinInp(1:giINPUTS)) - 0.5) * 2
	ENDDO	
	garValidationOutputs(:) = &
	((garValidationOutputs(:) - grMinOut) / (grMaxOut - grMinOut) - 0.5) * 2
	ENDIF

	PRINT *, ' Data normalised OK!'
	PRINT *, ''

END SUBROUTINE sScale_Data



SUBROUTINE sInitiate_Weights(arWIHL,arWHOL,arWIHBESTL,arWHOBESTL)
! generate initial random weights
	
	Real, Dimension (:,:),	Intent (INOUT) :: arWIHL
	Real, Dimension (:,:),	Intent (INOUT) :: arWIHBESTL	
	Real, Dimension (:), 	Intent (INOUT) :: arWHOL
	Real, Dimension (:),	Intent (INOUT) :: arWHOBESTL	

	INTEGER :: J, K
	REAL :: rRAND

	DO K=LBOUND(arWIHL,2),UBOUND(arWIHL,2)
		CALL RANDOM_NUMBER(rRAND)
		arWHOL(K)=((rRAND-0.5)*2)/10
		DO J=LBOUND(arWIHL,1),UBOUND(arWIHL,1)
			CALL RANDOM_NUMBER(rRAND)
			arWIHL(J,K)=((rRAND-0.5)*2)/10
		ENDDO
	ENDDO

	arWIHBESTL=arWIHL !record of best weights so far
	arWHOBESTL=arWHOL !record of best weights so far

END SUBROUTINE sInitiate_Weights


END PROGRAM Neural_Simulator