module rism_parm !initprmtop :: set to .true. if this is a new file logical, private :: initprmtop !filename :: file name of unit number. Obtained from INQUIRE character(len=1024),private :: filename !private function private :: NNBCHR contains !Call this subroutine before calling RISM_PARM_NXTSEC for the first time on a file. !Resets NXTSEC to read header information subroutine RISM_PARM_NXTSEC_INIT() implicit none initprmtop = .true. end subroutine RISM_PARM_NXTSEC_INIT ! ! Subroutine NeXT SECtion ! ! This routine reads data from a new-format PARM file. It ! searches for the section with a %FLAG header of FLAG. It returns ! the format for the section of data and places the file pointer on ! the first line of the data block. The actual data read is performed ! by the calling routine. ! ! Data are read from the file on unit IUNIT, which is assumed ! to already be open. ! ! IOK: 0, flag found and data read ! -1, then no %VERSION line found. This is an old-format PARM file. ! In this case, any call to NXTSEC will merely replace FMT with ! FMTOLD. This simplifies the calling procedure in the main ! routine, since FMT will contain the approprate FMT regardless ! of whether a new or old format PARM file is used (as long ! as FMTOLD was appropriately set in the call list). ! -2, then this is a new-format PARM file, but the requested ! FLAG was not found. (Only if IONERR = 1). ! ! Program stops if a specified flag is not found and this is a new-format ! PARM file. ! ! IUNIT: Unit for reads, assumed to already be open. ! IOUT: Unit for info/error writes ! IONERR: 0, then if a requested flag is not found, the program ! stops with an appropriate error ! 1, then if a requested flag is not found, the routine ! returns with IOK set to -2. ! FMTOLD: Format to use if read takes place from an old-style PARM file ! FLAG: Flag for data section to read. Must be large enough to hold ! any format string. Suggested length = char*255. ! FMT: Returned with format to use for data. File pointer will be ! at first line of data to be read upon return ! IOK: see above. ! ! IOUT: Unit for error prints ! ! Author: David Pearlman ! Date: 09/00 ! ! Scott Brozell June 2004 ! Converted loop control to Fortran 90; these changes are g77 compatible. ! ! Tyler Luchko December 2010 ! copied into rism directory and renamed to prevent collisions. Also, ! non-error output to IOUT is turned off. ! ! The PARM file has the following format. ! ! %VERSION VERSION_STAMP = Vxxxx.yyy DATE = mm:dd:yy hh:mm:ss ! ! This line should appear as the first line in the file, but this ! is not absolutely required. A search will be made for a line starting ! with %VERSION and followed by the VERSION_STAMP field. ! The version stamp is expected to be an F8.3 format field with ! leading 0's in place. E.g. V0003.22. Leading 0s should also ! be used for mm, dd, yy, hh, mm or ss fields that are < 10. ! ! %FLAG flag ! This line specifies the name for the block of data to follow ! FLAGS MUST NOT HAVE ANY EMBEDDED BLANKS. Use underscore characters ! in place of blanks, e.g. "BOND_PARMS" not "BOND PARMS". ! %FORMAT format ! This line provides the FORTRAN format for the data to follow. ! This should be specified using standard FORTRAN rules, and with the ! surrounding brackets intact. E.g. ! %FORMAT (8F10.3) ! **> Data starts with the line immediately following the %FORMAT line. ! The %FORMAT line and the data that follow will be associated with the ! flag on the most recent %FLAG line read. ! The actual data read is performed by the calling routine. ! All text following the %FORMAT flag is considered the format string ! and the string CAN have embedded blanks. ! %COMMENT comment ! Comment line. Will be ignored in parsing the file. A %COMMENT line ! can appear anywhere in the file EXCEPT A) between the %FORMAT ! line and the data; or B) interspersed with the data lines. ! While it recommended you use the %COMMENT line for clarity, it is ! not technically required for comment lines. Any line without ! a type specifier at the beginning of the line and which does not ! appear within the data block is assumed to be a comment. ! ! Note that in order to avoid confusion/mistakes, the above flags must ! be left justified (start in column one) on a line to be recognized. ! ! On the first call to this routine, it will search the file for ! %FLAG cards and store the lines they appear on. That way, on ! subsequent calls we'll know immediately if we should read further ! down the file, rewind, or exit with an error (flag not found). SUBROUTINE RISM_PARM_NXTSEC(IUNIT,IOUT,IONERR,FMTOLD,FLAG,FMT,IOK,o_VERSION) implicit none integer,intent(in) :: IUNIT integer,intent(in) :: IOUT integer,intent(in) :: IONERR character(len=*), intent(in) :: FMTOLD,FLAG character(len=*), intent(out) :: FMT integer,intent(out) :: IOK real, optional, intent(inout) :: o_VERSION logical FIRST SAVE FIRST DATA FIRST/.TRUE./ ! ! MXNXFL is maximum number of %FLAG cards that can be specified ! integer MXNXFL PARAMETER (MXNXFL = 500) CHARACTER*80 NXTFLG CHARACTER*8 PRDAT,PRTIM CHARACTER*255 AA integer IBLOCK integer INXTFL integer IPRVRR integer NUMFLG real RPVER COMMON /NXTLC1/INXTFL(2,MXNXFL),IPRVRR,NUMFLG,IBLOCK COMMON /NXTLC2/RPVER COMMON /NXTLC3/NXTFLG(MXNXFL),PRDAT,PRTIM integer I integer IPT integer IPT2 integer IPT3 integer IPT4 integer IPT5 integer IPT6 integer IPT7 integer IPT8 integer IPT9 integer IPT10 integer LFLAG integer IL2US integer IFIND integer MBLOCK integer ILFO IOK = 0 IF (FIRST.or.initprmtop) THEN inquire(unit=IUNIT,name=filename) ! REWIND(IUNIT) ! ! First, see if this is a new format PARM file. That is, if the %VERSION ! line exists. If not, then we assume it's an old format PARM file. In ! this case, every call to NXTSEC will simply result in an immediate ! return. This means all reads from the calling routine will be done ! sequentially from the PARM file. Store the version number as a real ! in RPVER. Store the date and time strings as character strings in ! PRDAT and PRTIM. ! do READ(IUNIT,11,END=20) AA 11 FORMAT(A) IF (AA(1:8).NE.'%VERSION') cycle ! IPT = INDEX(AA,'VERSION_STAMP') IF (IPT.LE.0) cycle ! IPT2 = NNBCHR(AA,IPT+13,0,0) IF (AA(IPT2:IPT2).NE.'=') GO TO 9000 ! IPT3 = NNBCHR(AA,IPT2+1,0,0) IF (AA(IPT3:IPT3).NE.'V') GO TO 9001 ! IPT4 = NNBCHR(AA,IPT3+1,0,1) IF (IPT4-1 - (IPT3+1) + 1 .NE.8) GO TO 9002 READ(AA(IPT3+1:IPT4-1),'(F8.3)') RPVER if(present(o_VERSION)) o_VERSION = RPVER ! IPT5 = INDEX(AA,'DATE') IF (IPT5.LE.0) THEN PRDAT = 'xx/xx/xx' PRTIM = 'xx:xx:xx' GO TO 50 END IF IPT6 = NNBCHR(AA,IPT5+4,0,0) IF (AA(IPT6:IPT6).NE.'=') GO TO 9003 IPT7 = NNBCHR(AA,IPT6+1,0,0) IPT8 = NNBCHR(AA,IPT7+1,0,1) IF (IPT8-1 - IPT7 + 1 .NE. 8) GO TO 9004 PRDAT = AA(IPT7:IPT8-1) IPT9 = NNBCHR(AA,IPT8+1,0,0) IPT10 = NNBCHR(AA,IPT9+1,0,1) IF (IPT10-1 - IPT9 + 1 .NE. 8) GO TO 9005 PRTIM = AA(IPT9:IPT10-1) ! WRITE(IOUT,15) RPVER,PRDAT,PRTIM ! 15 FORMAT('| New format PARM file being parsed.',/, ! * '| Version = ',F8.3,' Date = ',A,' Time = ',A) IPRVRR = 0 GO TO 50 end do ! ! Get here if no VERSION flag read. Set IPRVRR = 1 and return. ! On subsequent calls, if IPRVRR = 1, we return immediately. ! 20 IPRVRR = 1 IOK = -1 ! WRITE(IOUT,21) ! 21 FORMAT('| INFO: Old style PARM file read',/) fmt = fmtold rewind(iunit) first = .false. ! write (6,*) "setting initprmtop to F" initprmtop=.false. RETURN ! ! %VERSION line successfully read. Now load the flags into NXTFLG(I) ! and the line pointer and lengths of the flags into ! INXTFL(1,I) and INXTFL(2,I), respectively. NUMFLG will be the ! total number of flags read. ! 50 REWIND(IUNIT) NUMFLG = 0 I = 1 do READ(IUNIT,11,END=99) AA IF (AA(1:5).EQ.'%FLAG') THEN NUMFLG = NUMFLG + 1 IPT2 = NNBCHR(AA,6,0,0) IF (IPT2.EQ.-1) GO TO 9006 IPT3 = NNBCHR(AA,IPT2,0,1)-1 INXTFL(1,NUMFLG) = I INXTFL(2,NUMFLG) = IPT3-IPT2+1 NXTFLG(NUMFLG) = AA(IPT2:IPT3) END IF I = I + 1 end do 99 REWIND(IUNIT) IBLOCK = 0 FIRST = .FALSE. initprmtop=.false. END IF ! ! Start search for passed flag name ! ! If this is an old-style PARM file, we can't do the search. Simply ! set IOK = -1, FMT to FMTOLD, and return ! IF (IPRVRR.EQ.1) THEN IOK = -1 FMT = FMTOLD RETURN END IF ! LFLAG = NNBCHR(FLAG,1,0,1)-1 IF (LFLAG.EQ.-2) LFLAG = LEN(FLAG) DO I = 1,NUMFLG IF (LFLAG.EQ.INXTFL(2,I)) THEN IF (FLAG(1:LFLAG).EQ.NXTFLG(I)(1:LFLAG)) THEN IL2US = INXTFL(1,I) GO TO 120 END IF END IF END DO ! ! Get here if flag does not correspond to any stored. Either stop ! or return depending on IONERR flag. ! IF (IONERR.EQ.0) THEN GO TO 9007 ELSE IF (IONERR.EQ.1) THEN IOK = -2 RETURN END IF ! ! Flag found. Set file pointer to the first line following the appropriate ! %FLAG line and then search for %FORMAT field. ! ! IBLOCK keeps track of the last %FLAG found. If this preceeded the ! one being read now, we read forward to find the current requested FLAG. ! If this followed the current request, rewind and read forward the ! necessary number of lines. This should speed things up a bit. ! 120 IFIND = I MBLOCK = IBLOCK IF (IFIND.GT.IBLOCK) THEN do READ(IUNIT,11,END=9008) AA IF (AA(1:5).EQ.'%FLAG') THEN MBLOCK = MBLOCK + 1 IF (MBLOCK.EQ.IFIND) exit END IF end do ELSE REWIND(IUNIT) DO I = 1,IL2US READ(IUNIT,11,END=9008) END DO END IF DO READ(IUNIT,11,END=9009) AA IF (AA(1:7).EQ.'%FORMAT') exit END DO ! ! First %FORMAT found following appropriate %FLAG. Extract the ! format and return. All non-blank characters following %FORMAT ! comprise the format string (embedded blanks allowed). ! IPT2 = NNBCHR(AA,8,0,0) IF (IPT2.EQ.-1) GO TO 9010 DO I = LEN(AA),IPT2,-1 IF (AA(I:I).NE.' ') exit END DO IPT3 = I ! ! Format string is in IPT2:IPT3. Make sure passed FMT string is large ! enought to hold this and then return. ! ILFO = IPT3-IPT2+1 IF (ILFO.GT.LEN(FMT)) GO TO 9011 FMT = ' ' FMT(1:ILFO) = AA(IPT2:IPT3) ! ! Update IBLOCK pointer and return ! IBLOCK = IFIND RETURN ! ! Errors: ! 9000 WRITE(IOUT,9500) trim(filename) 9500 FORMAT('ERROR: File ',A,': No = sign after VERSION_STAMP field') STOP 9001 WRITE(IOUT,9501) trim(filename) 9501 FORMAT('ERROR: File ',A,': Version number does not start with V') STOP 9002 WRITE(IOUT,9502) trim(filename) 9502 FORMAT('ERROR: File ',A,': Mal-formed version number', & 'Should be 8 chars') STOP 9003 WRITE(IOUT,9503) trim(filename) 9503 FORMAT('ERROR: File ',A,': No = sign after DATE field') STOP 9004 WRITE(IOUT,9504) trim(filename) 9504 FORMAT('ERROR: File ',A,': Mal-formed date string.', & 'Should be 8 characters & no embedded spaces.') STOP 9005 WRITE(IOUT,9505) trim(filename) 9505 FORMAT('ERROR: File ',A,': Mal-formed time string. ', & 'Should be 8 characters & no embedded spaces.') STOP 9006 WRITE(IOUT,9506) trim(filename) 9506 FORMAT('ERROR: File ',A,': No flag found following a %FLAG line') STOP 9007 WRITE(IOUT,9507) trim(filename), FLAG(1:LFLAG) 9507 FORMAT('ERROR: File ',A,': Flag "',A,'" not found') STOP 9008 WRITE(IOUT,9508) trim(filename), FLAG(1:LFLAG) 9508 FORMAT('ERROR: File ',A,': Programming error in routine NXTSEC at "',A,'"') STOP 9009 WRITE(IOUT,9509) trim(filename), FLAG(1:LFLAG) 9509 FORMAT('ERROR: File ',A,': No %FORMAT field found following flag "',A,'"') STOP 9010 WRITE(IOUT,9510) trim(filename), FLAG(1:LFLAG) 9510 FORMAT('ERROR: File ',A,': No format string found following a %FORMAT ', & 'line',/,'Corresponding %FLAG is "',A,'"') STOP 9011 WRITE(IOUT,9511) trim(filename), FLAG(1:LFLAG) 9511 FORMAT('ERROR: File ',A,': Format string for flag "',A,'" too large',/, & ' for FMT call-list parameter') STOP ! END SUBROUTINE RISM_PARM_NXTSEC ! FUNCTION NNBCHR(AA,IBEG,IEND,IOPER) ! ! IOPER = 0: Find next non-blank character ! IOPER = 1: Find next blank character ! ! On return, NNBCHR is set to the appropriate pointer, or to -1 ! if no non-blank character found (IOPER = 0) or no blank ! character found (IOPER = 1). ! implicit none integer NNBCHR character*(*) AA integer IBEG integer IEND integer IOPER integer I integer IBG integer IEN IBG = IBEG IEN = IEND IF (IBEG.LE.0) IBG = 1 IF (IEND.LE.0) IEN = LEN(AA) ! IF (IOPER.EQ.0) THEN DO I = IBG,IEN IF (AA(I:I).NE.' ') THEN NNBCHR = I RETURN END IF end do NNBCHR = -1 ELSE IF (IOPER.EQ.1) THEN do I = IBG,IEN IF (AA(I:I).EQ.' ') THEN NNBCHR = I RETURN END IF end do NNBCHR = -1 END IF ! RETURN END FUNCTION NNBCHR end module rism_parm