! http://www.philbrierley.com/main.html?code/fortran.html&code/codeleft.html
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
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