PROGRAM W3ADC C/ C/ +-----------------------------------+ C/ | H. L. Tolman | C/ | FORTRAN 77 | C/ | Last update : 05-Jan-2001 | C/ +-----------------------------------+ C/ C/ Version to preprocess FORTRAN 90 free format code. C/ C 1. Purpose : C C Pre-processing of FORTRAN files by switching on and of of C selected lines and by including COMMON's. C C - Based on ADCOM by N. Booij, C Delft University of Technology. C - Refinement of WWADC C - FORTRAN 90 compatible C C 2. Method : C C From standard input the following data are read: C - Test indicator and compress indicator ( 1 line ). C - File name of the input and output code ( 1 line ). C - Switches to be turned on ( 1 line ). C - Include string and file name ( n lines ). C C where : C C test indicator : 0 : no test output C >0 : (more) test output C compress ind. : 0 : no file compression C 1 : Remove comments except for empty switches. C 2 : Remove all comment. C C Output is read using free format, so quotes are needed around C strings. Echo and test output is send to the standard output C device. Switches can be up to NLSWTC characters long, and are C separated by spaces. C C 3. Parameters : C C Data in PARAMETER statements : C ---------------------------------------------------------------- C MMLOUT Int. Line length of output. C MMSWTC Int. Maximum number of switches. C MMFILE Int. Maximum number of include files. C MMLINE Int. Maximum length of include files. C ---------------------------------------------------------------- C C Internal data : C ---------------------------------------------------------------- C ITEST Int. Test indicator (see section 2). C ICOMP Int. Compression indicator (see section 2). C NSWTCH Int. Number of switches (total). C NLSWTC Int. Maximum length of switches. C NFILES Int. Number of include files. C NLINES I.A. Length of include files. C IDLEN I.A. Length of ID string for include file. C MMLNGT Int. Maximum length of include files. C ---------------------------------------------------------------- C C 4. Subroutines used : C C None. C C 5. Called by : C C None (stand alone program). C C 6. Error messages : C C - Checks on array sizes. C - Open errors on files. C C 7. Remarks : C C - Switches are case-sensitive C - Switch in code has to be followed by space. C - Switches can be used in include files, since include files are C are pre-processed before the actual file is processed. Includes C in include files, however, are not accepted. C - By dealing with swtiches before looking for include files, C the inclusion of files can be governed by switches. C - Variable record lengths used by looking for last non-blank. C - ID string for inclusion of file can be anything, and may C include blanks. C C 8. Structure : C C ===================================================== C Initializations C Read from standard input and proparations C ---------------------------------------------------- C ITEST and ICOMP C Read names of input and output files and open C Read and process switches. C Process include files C ------------------------------------------------ C Get and store ID string C Preprocess include file C ---------------------------------------------- C Process switches C Check for keeping of line (compress) C Determine line lengths C ===================================================== C Actual processing C For every line do C ---------------------------------------------------- C Process switches C Check for include files C If no include C -------------------------------------------------- C Check for keeping of line (compress) C Determine actual line length C Write line C ===================================================== C C 9. Source code : C * ---------------------------------------------------------------------- * PARAMETER ( MMLOUT = 132 ) PARAMETER ( MMFILE = 30 ) PARAMETER ( MMSWTC = 52 ) PARAMETER ( MMLINE = 200 ) * INTEGER NSWTCH, IDLEN(MMFILE), NLINES(MMFILE), LL, & LENGTH(MMFILE,MMLINE), NINCF(MMFILE), LS(MMSWTC) LOGICAL FLOLD, FLKEEP, FLINCL, FLSWTC, LSTEXC, NOWEXC, & QUOTES * CHARACTER*20 TEST0, TSTSTR CHARACTER*500 FNAMEI, FNAMEO, FNAMER CHARACTER*72 INSTR CHARACTER*143 NEWLNE, OLDLNE CHARACTER*200 SWTCHS CHARACTER*33 NOLINE CHARACTER SWITCH*8, SW0*8 DIMENSION SWITCH(MMSWTC), TSTSTR(MMFILE), INSTR(MMFILE,MMLINE) * * initialisations * NOLINE = '. . . . . . . . . . . ' * * set test parameters -------------------------------------------------- * NLSWTC = LEN(SWITCH(1)) * READ (*,*) ITEST, ICOMP ITEST = MAX ( ITEST , 0 ) ICOMP = MIN ( MAX(ICOMP,0) , 2 ) WRITE (*,900) ITEST, ICOMP * * Read file names ------------------------------------------------------ * READ (*,*) FNAMEI, FNAMEO NDSIN = 10 NDSOUT = 11 WRITE (*,910) FNAMEI, FNAMEO * OPEN (NDSIN ,FILE=FNAMEI,ERR=801,STATUS='OLD') OPEN (NDSOUT,FILE=FNAMEO,ERR=802) * * Read switches -------------------------------------------------------- * READ (*,*) SWTCHS NSWTCH = 0 FLOLD = .FALSE. * DO 100, I=1, 200 IF (SWTCHS(I:I).NE.' ') THEN IF ( FLOLD ) THEN J = J + 1 IF (J.GT.NLSWTC) THEN WRITE (*,*) '*** ERROR: SWITCH TOO LONG' STOP ENDIF SW0(J:J) = SWTCHS(I:I) ELSE IF (NSWTCH+1.GT.MMSWTC) THEN WRITE (*,*) '*** ERROR: TOO MANY SWITCHES' STOP ENDIF NSWTCH = NSWTCH + 1 J = 1 SW0(1:1) = SWTCHS(I:I) FLOLD = .TRUE. ENDIF ELSE IF ( FLOLD ) THEN SWITCH(NSWTCH) = SW0(1:J) LS (NSWTCH) = J ENDIF FLOLD = .FALSE. ENDIF 100 CONTINUE * IF ( FLOLD ) THEN SWITCH(NSWTCH) = SW0(1:J) LS (NSWTCH) = J ENDIF * WRITE (*,920) NSWTCH IF (ITEST.EQ.0) THEN WRITE (*,921) (SWITCH(I),I=1,NSWTCH) ELSE DO 90, J=1, NSWTCH SW0 = SWITCH(J) WRITE (*,922) J, SW0(1:LS(J)) 90 CONTINUE ENDIF * * get include files ---------------------------------------------------- * NDSINC = 50 NFILES = 0 WRITE (*,930) 110 CONTINUE READ (*,*,END=200,ERR=200) TEST0, FNAMER NFILES = NFILES + 1 NINCF(NFILES) = 0 IF (NFILES.GT.MMFILE) THEN WRITE (*,*) '*** ERROR: TOO MANY INCLUDE FILES' STOP ENDIF IF (ITEST.GE.3) WRITE (*,9930) TEST0, FNAMER * * store ID string and determine its length - - - - - - - - - - - - - - - * TSTSTR(NFILES) = TEST0 DO 120 J=LEN(TEST0),1,-1 IDLEN(NFILES) = J IF (TEST0(J:J).NE.' ') GOTO 121 120 CONTINUE 121 CONTINUE IF (ITEST.GE.2) WRITE (*,9931) IDLEN(NFILES) * * (pre-) process include file - - - - - - - - - - - - - - - - - - - - - * ILINE1 = 0 ILINE2 = 0 NDSINC = NDSINC+1 OPEN (NDSINC,FILE=FNAMER,ERR=803,STATUS='OLD') LSTEXC = .FALSE. 130 CONTINUE READ (NDSINC,'(A)',END=190,ERR=190) NEWLNE ILINE1 = ILINE1 + 1 * * switches * FLKEEP = .TRUE. FLSWTC = .FALSE. * IF ( NEWLNE(1:2).EQ.'!/' ) THEN FLKEEP = .FALSE. IF ( NEWLNE(3:3) .EQ. ' ' ) THEN FLSWTC = .TRUE. GOTO 141 ENDIF DO 140, I=1, NSWTCH SW0 = SWITCH(I) J = LS(I) IF ( NEWLNE( 3 :2+J) .EQ. SW0(1:J) ) THEN IF ( NEWLNE(3+J:3+J) .EQ. ' ' ) THEN NEWLNE(1:MMLOUT) = NEWLNE(3+J:MMLOUT+3+J-1) FLSWTC = .TRUE. GOTO 141 ENDIF IF ( NEWLNE(3+J:3+J) .EQ. '/' ) THEN NEWLNE(1:MMLOUT) = NEWLNE(4+J:MMLOUT+4+J-1) FLSWTC = .TRUE. GOTO 141 ENDIF ENDIF 140 CONTINUE 141 CONTINUE ENDIF * * keep line ... * FLKEEP = FLKEEP .OR. FLSWTC * IF (ICOMP.GE.1) FLKEEP = FLSWTC .OR. .NOT. (NEWLNE(1:1).EQ.'!') IF (ICOMP.GT.1) FLKEEP = FLKEEP .AND. (NEWLNE(1:2).NE.'!/') * IF ( FLKEEP ) THEN DO 150 J=MMLOUT,1,-1 LL = J IF (NEWLNE(J:J).NE.' ') GOTO 151 150 CONTINUE 151 CONTINUE * IF ( ICOMP.NE.0 .AND. .NOT.FLSWTC ) THEN QUOTES = .FALSE. DO 155 J=1,LL IF (.NOT.QUOTES .AND. NEWLNE(J-1:J-1).EQ.'!') GOTO 156 IF (NEWLNE(J-1:J-1).EQ.'''') QUOTES = .NOT. QUOTES 155 CONTINUE 156 CONTINUE LL = MIN ( J , LL ) ENDIF * ENDIF * NOWEXC = NEWLNE(1:1).EQ.'!' .AND. LL.EQ.1 FLKEEP = FLKEEP .AND. .NOT. (LSTEXC.AND.NOWEXC) * IF (FLKEEP) THEN LSTEXC = NOWEXC ILINE2 = ILINE2 + 1 IF (ILINE2.GT.MMLINE) THEN WRITE (*,*) '*** ERROR: TOO MANY INCLUDE LINES' STOP ENDIF INSTR(NFILES,ILINE2) = NEWLNE(1:MMLOUT) * * line length * LENGTH(NFILES,ILINE2) = LL ENDIF * * next line * GOTO 130 190 CONTINUE NLINES(NFILES) = ILINE2 WRITE (*,931) TEST0, FNAMER, ILINE1, ILINE2 * IF (ITEST.GE.2) THEN WRITE (*,9932) FNAMER DO 191, I=1,NLINES(NFILES) IF (ITEST.GE.3) THEN WRITE (*,9933) INSTR(NFILES,I)(1:LENGTH(NFILES,I)), & ('.',J=LENGTH(NFILES,I)+1,72), '|' ELSE WRITE (*,9933) INSTR(NFILES,I)(1:72), '|' ENDIF 191 CONTINUE WRITE (*,9934) ENDIF * * next include file * GOTO 110 200 CONTINUE IF (ITEST.GE.2) THEN WRITE (*,9999) STOP ENDIF * * Preprocessing finished, start processing file ------------------------ * NINP = 0 NOUT = 0 NINCL = 0 LSTEXC = .FALSE. IF (ITEST.GE.1) WRITE (*,9940) 300 CONTINUE READ (NDSIN ,'(A)',END=400,ERR=400) NEWLNE NINP = NINP + 1 * OLDLNE = NEWLNE * * switches * FLKEEP = .TRUE. FLSWTC = .FALSE. * IF ( NEWLNE(1:2).EQ.'!/' ) THEN FLKEEP = .FALSE. IF ( NEWLNE(3:3) .EQ. ' ' ) THEN FLSWTC = .TRUE. GOTO 311 ENDIF DO 310, I=1, NSWTCH SW0 = SWITCH(I) J = LS(I) IF ( NEWLNE( 3 :2+J) .EQ. SW0(1:J) ) THEN IF ( NEWLNE(3+J:3+J) .EQ. ' ' ) THEN NEWLNE(1:MMLOUT) = NEWLNE(3+J:MMLOUT+3+J-1) FLSWTC = .TRUE. GOTO 311 ENDIF IF ( NEWLNE(3+J:3+J) .EQ. '/' ) THEN NEWLNE(1:MMLOUT) = NEWLNE(4+J:MMLOUT+4+J-1) FLSWTC = .TRUE. GOTO 311 ENDIF ENDIF 310 CONTINUE 311 CONTINUE ENDIF * * include ??? * FLINCL = .FALSE. DO 330, J=1, NFILES IF (NEWLNE(1:IDLEN(J)).EQ.TSTSTR(J)(1:IDLEN(J))) THEN IF (ITEST.GE.1) THEN WRITE (*,9941) OLDLNE, NOLINE NOLINE(1 :32) = NOLINE( 2:33) NOLINE(33:33) = NOLINE( 3: 3) ENDIF DO 320, I=1,NLINES(J) WRITE (NDSOUT,'(A)') INSTR(J,I)(1:LENGTH(J,I)) 320 CONTINUE IF (ITEST.GE.1) THEN DO 321, I=1,NLINES(J) WRITE (*,9941) NOLINE, INSTR(J,I) NOLINE(1 :32) = NOLINE( 2:33) NOLINE(33:33) = NOLINE( 3: 3) 321 CONTINUE ENDIF FLINCL = .TRUE. NINCL = NINCL + 1 NINCF(J) = NINCF(J) + 1 NOUT = NOUT + NLINES(J) GOTO 331 ENDIF 330 CONTINUE 331 CONTINUE * * keep line ... * IF (.NOT.FLINCL) THEN FLKEEP = FLKEEP .OR. FLSWTC * IF (ICOMP.GE.1) FLKEEP = FLSWTC .OR. .NOT.(NEWLNE(1:1).EQ.'!') IF (ICOMP.GT.1) FLKEEP = FLKEEP .AND. (NEWLNE(1:2).NE.'!/') * IF ( FLKEEP ) THEN DO 350 J=MMLOUT,1,-1 LL = J IF (NEWLNE(J:J).NE.' ') GOTO 351 350 CONTINUE 351 CONTINUE * IF ( ICOMP.NE.0 .AND. .NOT.FLSWTC ) THEN QUOTES = .FALSE. DO 355 J=1,LL IF (.NOT.QUOTES .AND. NEWLNE(J-1:J-1).EQ.'!') & GOTO 356 IF (NEWLNE(J-1:J-1).EQ.'''') QUOTES = .NOT. QUOTES 355 CONTINUE 356 CONTINUE LL = MIN ( J , LL ) ENDIF * ENDIF * NOWEXC = NEWLNE(1:1).EQ.'!' .AND. LL.EQ.1 FLKEEP = FLKEEP .AND. .NOT. (LSTEXC.AND.NOWEXC) * IF (FLKEEP) THEN LSTEXC = NOWEXC * * write line * WRITE (NDSOUT,'(A)') NEWLNE(1:LL) NOUT = NOUT + 1 IF (ITEST.GE.1) WRITE (*,9941) OLDLNE, NEWLNE * ELSE IF (ITEST.GE.1) THEN WRITE (*,9941) OLDLNE, NOLINE NOLINE(1 :32) = NOLINE( 2:33) NOLINE(33:33) = NOLINE( 3: 3) ENDIF ENDIF * * next line * GOTO 300 400 CONTINUE * * End of processing ---------------------------------------------------- * IF (ITEST.GE.1) WRITE (*,9942) WRITE (*,950) NINP, NOUT, NINCL IF (NINCL.NE.0) THEN WRITE (*,951) DO 410, J=1, NFILES IF (NINCF(J).NE.0) WRITE (*,952) NINCF(J), TSTSTR(J) 410 CONTINUE ENDIF * STOP ' ' * * Error escape locations * 801 CONTINUE WRITE (*,*) '*** ERROR: OPENING INPUT FILE' STOP * 802 CONTINUE WRITE (*,*) '*** ERROR: OPENING OUTPUT FILE' STOP * 803 CONTINUE WRITE (*,*) '*** ERROR: OPENING INCLUDE FILE ', FNAMER STOP * * Formats * 900 FORMAT (/' W3ADC, WAVEWATCH FORTRAN PREPROCESSING : '/ & ' =========================================='// & ' ITEST =',I4/ & ' ICOMP =',I4) 910 FORMAT ( ' INPUT FILE : ',A/ & ' OUTPUT FILE : ',A) 920 FORMAT ( ' NUMBER OF SWITCHES:',I4,' SWITCHES :') 921 FORMAT ( ' ',8(A,1X)) 922 FORMAT ( ' ',I4,' >',A,'<') 930 FORMAT (/' INCLUDE FILES :'// & ' ID_STRING FILENAME ', & ' LINES '/ & ' ----------------------------------', & '---------------------------------------') 931 FORMAT ( ' ',A20,2X,A40,2X,2I4) 950 FORMAT (/' FINAL STATISTICS : '/ & ' INPUT LINES :',I6/ & ' OUTPUT LINES :',I6/ & ' FILES INCLUDED :',I6,' TOTAL') 951 FORMAT ( ' ------------------------', & '--------------------') 952 FORMAT ( ' ',I6,2X,A) * 9930 FORMAT ( ' TEST W3ADC/3 : ',A,2X,A) 9931 FORMAT ( ' TEST W3ADC/3 : ',I10) 9932 FORMAT ( ' TEST W3ADC/2 : INCULDE FILE ',A/ & ' +------------------------------------', & '------------------------------------+') 9933 FORMAT ( ' |',73A) 9934 FORMAT ( ' +------------------------------------', & '------------------------------------+'/) 9940 FORMAT (/' TEST W3ADC/1 '/ & ' INPUT ', & ' OUTPUT'/ & ' +---------------------------------+ ', & ' +---------------------------------+') 9941 FORMAT ( ' |',A33,'| |',A33,'|') 9942 FORMAT ( ' +---------------------------------+ ', & ' +---------------------------------+') 9999 FORMAT ( ' TEST W3ADC/2 : PROGRAM ENDED DUE TO VALUE OF ITEST'/) * * End of W3ADC -------------------------------------------------------- * END