Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 1 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. PROGRAM PEAKFQBATCH Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1 C 2 C 3 C 4 PROGRAM PEAKFQBATCH 5 C 6 C + + + PURPOSE + + + 7 C Batch version of PEAKFQ program. 8 C 9 C + + + HISTORY + + + 10 C created for batch version of PEAKFQ, 9/03 11 C Paul Hummel of AQUA TERRA Consultants 12 C 13 USE CompSpecs 14 C 15 C + + + PARAMETERS + + + 16 INCLUDE 'pmxint.inc' 17 INCLUDE 'pmesfl.inc' 18 C 19 C + + + COMMON BLOCKS + + + 20 INCLUDE 'cpkdsn.inc' 21 INCLUDE 'clunit.inc' 22 INCLUDE 'cjobop.inc' 23 INCLUDE 'cwcf0.inc' 24 C 25 C + + + LOCAL VARIABLES + + + 26 INTEGER I,J,K,STAIND,IOSNUM 27 INTEGER IPEND, WDMSFL, FOUT, PAUSE, EMAOPT 28 INTEGER LNSPECS, NSTA, ISTA, RETCOD, RDOFLG, FE | WARNING -- INTEGER scalar (RDOFLG) is never used. 29 INTEGER DSN, DSTYP, GRCNT, LREC 30 CHARACTER*12 APNAME 31 CHARACTER*8 LGNAME 32 CHARACTER*64 FNAME, VERSN 33 CHARACTER*80 S, KWD, SPCFNM, IOSTXT 34 CHARACTER*80, ALLOCATABLE :: SPECS(:), LSPECS(:) 35 LOGICAL LFLAG 36 C 37 C + + + FUNCTIONS + + + 38 INTEGER ZLNTXT, CVRINT 39 CHARACTER*80 STRRETREM 40 INTEGER INFOERROR | WARNING -- INTEGER scalar (INFOERROR) is never used. 41 C 42 C + + + EXTERNALS + + + 43 EXTERNAL ZLNTXT, CVRINT, STRRETREM, J407XE, JFLUSH, WDBOPN 44 EXTERNAL GPOPEN, GPINIT, ANINIZ, WRITESPECIO, UPDATESPECFILE 45 EXTERNAL WDDSNX, WDSCHK 46 C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 2 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 47 C + + + INPUT FORMATS + + + 48 1000 FORMAT(A80) 49 C 50 C + + + END SPECIFICATIONS + + + 51 C 52 C avoid some lahey math errors 53 LFLAG = .TRUE. 54 CALL INVALOP (LFLAG) 55 CALL UNDFL (LFLAG) 56 C 57 C Initialize user environment 58 C version info for unix what 59 C names of application, message file, and log file 60 INCLUDE 'fpeak.inc' 61 CALL ANINIZ (MESSFL, FNAME, LGNAME) 62 C 63 C init graphics 64 CALL GPOPEN (FE) 65 C always doing some graphics (BMP at a minimum) 66 CALL GPINIT 67 C 68 C assume not going to update the specification file 69 UPDATEFG = .FALSE. 70 C 71 C init options 72 Ckmf? what do these next 4 variables do? 73 Cprh previously set in OPNOUT, used sporatically in J407XE.FOR 74 Cprh found in common JOBOPT 75 IPPOS = 1 76 ISKUDP= 0 77 NOXPA = 0 78 NOCLM = 0 79 C 80 C init output options 81 WEIBA = 0.0 !common WCFCM0 82 C common JOBOPT (IPLTOP through ALLSOM) 83 IPLTOP= 0 84 IPRTOP= 1 85 IBCPUN= 0 86 IDEBUG= 0 87 IMODFG= 1 88 ALLSOM= 1 89 PAUSE = 2 !don't pause between stations 90 EMAOPT= 0 !default to not do EMA analysis 91 C 92 C open scratch file 93 OPEN (UNIT=91,FILE='RQ7J4ZV9',STATUS='UNKNOWN') 94 C 95 CC open the old WDM message file (read only if possible) 96 C MESSFL= 9 97 C FILNAM= '\HASSAPPS\PEAKFQ.NEW\BIN\PKFQMS.WDM' 98 C RDOFLG= 1 Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 3 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 99 C CALL WDBOPN (MESSFL,FILNAM,RDOFLG, 100 C O RETCOD) 101 C IF (RETCOD.NE.0) THEN 102 CC bad wdm file 103 C WRITE(91,*) 'Bad Message File:',RETCOD,FILNAM 104 C WRITE(*,*) 'Bad Message File:',RETCOD,FILNAM 105 C STOP 106 C END IF 107 108 SPCFUN = 11 109 C get driver input file from command line arguement 110 CALL GETCL(SPCFNM) 111 OPEN(SPCFUN,FILE=SPCFNM,IOSTAT=IOSNUM,ERR=5) 112 C successful open of spec file 113 WRITE(*,*) "MAIN:Reading Specification file: ",SPCFNM 114 GO TO 8 115 116 5 CONTINUE !problem opening spec file 117 CALL IOSTAT_MSG(IOSNUM,IOSTXT) 118 write(*,*) "Unable to open Specification file: ",SPCFNM 119 GO TO 999 120 121 8 CONTINUE 122 123 C scan file for stations 124 write(*,*) "Scanning Spec file for stations. Spec file contents:" 125 NSTA = 0 126 DO !loop to count stations to process 127 READ(SPCFUN,1000,IOSTAT=IOSNUM,END=10) S 128 write(*,*) " " // S 129 CALL UPCASE(S) 130 IF (S(1:7) .EQ. 'STATION') THEN 131 NSTA = NSTA + 1 132 END IF 133 END DO 134 10 CONTINUE !get here on end of file 135 write(*,*) "Finished scan of Spec file." 136 137 REWIND(SPCFUN,IOSTAT=IOSNUM,ERR=20) 138 write(*,*) "Just did REWIND of spec file." 139 GO TO 30 140 141 20 CONTINUE !get here on REWIND error 142 write(*,*) "Prblem with REWIND, IO: ",S 143 144 30 CONTINUE 145 146 IF (NSTA .GT. 0) THEN 147 WRITE (*,*) "MAIN:Found ",NSTA," Stations" 148 ALLOCATE (STASPECS(NSTA)) 149 ALLSOM = 2 !only doing specified stations 150 ELSE !all stations, no updates to specifications Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 4 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 151 WRITE (*,*) "MAIN:No Stations Found - Do All" 152 END IF 153 154 ISTA = 0 155 IPEND = 0 156 C process driver input file 157 DO 158 IF (IPEND .EQ. 0) THEN !read next record 159 READ(SPCFUN,1000,IOSTAT=IOSNUM,END=120) S 160 WRITE(*,*) "MAIN:Process Record:'" // TRIM(S) // "'" 161 CALL UPCASE(S) 162 KWD = STRRETREM(S) 163 ELSE !have record pending to process 164 IPEND = 0 !reset 165 END IF 166 167 IF (KWD .EQ. 'I') THEN !input spec 168 WRITE(*,*) "MAIN:Got I, Remaining:'" // TRIM(S) // "'" 169 CALL OPNINP 170 M (S,WDMSFL,INCRD,INFORM,RETCOD) 171 ELSE IF (KWD .EQ. 'O') THEN !output spec 172 WRITE(*,*) "MAIN:Got O, Remaining:'" // TRIM(S) // "'" 173 CALL OPNOUT 174 M (S, INFORM, FOUT, IPUNCH, 175 M IPLTOP, GRFMT, IPRTOP, IBCPUN, IDEBUG, 176 M CLSIZE, WEIBA, EMAOPT, 177 O RETCOD) 178 ELSE IF (KWD .EQ. 'STATION') THEN !processing station specs 179 WRITE(*,*) "MAIN:Got STATION, Remaining:'" // TRIM(S) // "'" 180 LNSPECS= 0 181 ISTA = ISTA + 1 182 STASPECS(ISTA)%ID = TRIM(S) 183 IF (ISTA.GT.1) THEN !look for duplicate station IDs 184 I = ISTA - 1 185 DO WHILE (I.GT.0) 186 J = ZLNTXT(STASPECS(ISTA)%ID) 187 IF (STASPECS(I)%ID(1:J).EQ.STASPECS(ISTA)%ID) THEN 188 C same station ID, add an index 189 K = ZLNTXT(STASPECS(I)%ID) 190 IF (K.GT.J) THEN 191 C this station already has an index, increment it 192 STAIND = CVRINT(STASPECS(I)%ID(J+2:K)) + 1 193 IF (STAIND.LT.10) THEN 194 WRITE(STASPECS(ISTA)%ID,'(I1)') 195 $ TRIM(STASPECS(ISTA)%ID) // "-",STAIND 196 ELSE 197 WRITE(STASPECS(ISTA)%ID,'(I2)') 198 $ TRIM(STASPECS(ISTA)%ID) // "-",STAIND 199 END IF 200 ELSE !first duplicate of this station 201 STASPECS(ISTA)%ID = TRIM(STASPECS(ISTA)%ID) // "-1" 202 END IF Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 5 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 203 WRITE(*,*) "Duplicate Station ID: updated original ", 204 $ TRIM(S)," to be ",STASPECS(ISTA)%ID 205 I = 0 !exit loop 206 END IF 207 I = I - 1 208 END DO 209 END IF 210 WRITE (*,*) "MAIN:Assigned " // STASPECS(ISTA)%ID // 211 $ " to index ", ISTA," of STASPECS" 212 DO WHILE (IPEND .EQ. 0) !loop for station specs 213 READ(SPCFUN,1000,END=90) S 214 CALL UPCASE(S) 215 WRITE(*,*) "MAIN:Process RecordX:'" // TRIM(S) // "'" 216 KWD = STRRETREM(S) 217 IF (KWD.EQ.'STATION'.OR.KWD.EQ.'I'.OR.KWD.EQ.'O'.OR. 218 $ KWD.EQ.'UPDATE') THEN 219 C some other spec, end specs for this station 220 IPEND = 1 221 ELSE 222 C add record to this station's specs 223 WRITE(*,*) "MAIN:Add Record To Station Specs" 224 S = TRIM(KWD) // ' ' // TRIM(S) 225 IF (LNSPECS .GT. 0) THEN !make copy of existing specs 226 WRITE(*,*) "MAIN:Add to existing specs" 227 ALLOCATE (LSPECS(LNSPECS)) 228 DO 70 I = 1, LNSPECS 229 LSPECS(I) = SPECS(I) 230 70 CONTINUE 231 DEALLOCATE (SPECS) 232 END IF 233 LNSPECS = LNSPECS + 1 234 WRITE(*,*) "MAIN:LNSPECS:", LNSPECS 235 ALLOCATE (SPECS(LNSPECS)) 236 IF (LNSPECS .GT. 1) THEN 237 DO 80 I = 1,LNSPECS-1 238 SPECS(I) = LSPECS(I) !put copy back 239 80 CONTINUE 240 DEALLOCATE(LSPECS) 241 END IF 242 WRITE (*,*) "MAIN:Assign spec:'" // TRIM(S) // "'" 243 SPECS(LNSPECS) = S !assign new spec 244 END IF 245 END DO 246 247 90 CONTINUE !get here on EOF within station specs 248 249 IF (LNSPECS.GT.0) THEN !specs exist for this station 250 ALLOCATE(STASPECS(ISTA)%SPECS(LNSPECS)) 251 STASPECS(ISTA)%NSPECS = LNSPECS 252 WRITE(*,*) "MAIN:", STASPECS(ISTA)%NSPECS, 253 $ " spec(s) for station ",STASPECS(ISTA)%ID 254 DO 100 I = 1,LNSPECS Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 6 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 255 STASPECS(ISTA)%SPECS(I)%STR = SPECS(I) 256 WRITE(*,*) " Spec", I, ": '" // 257 $ TRIM(STASPECS(ISTA)%SPECS(I)%STR) // "'" 258 100 CONTINUE 259 DEALLOCATE(SPECS) 260 END IF 261 ELSE IF (KWD .EQ. 'UPDATE') THEN 262 C update spec file with verbose specifications 263 UPDATEFG = .TRUE. 264 END IF 265 END DO 266 120 CONTINUE !get here on EOF (or other error) 267 CALL IOSTAT_MSG(IOSNUM,IOSTXT) 268 WRITE(*,*) "Done reading spec file, status : ",IOSTXT 269 270 IF (INFORM.EQ.1) THEN !populate DSN buffer 271 IF (NSTA.GT.0) THEN !get from station specs 272 DO 150 I = 1,NSTA 273 DSNBUF(I) = CVRINT(STASPECS(I)%ID) 274 150 CONTINUE 275 DSNCNT = NSTA 276 ELSE !no specs, find all available data sets 277 DSTYP = 2 278 DSNCNT = 0 279 DSN = 1 280 DO WHILE (DSN.GT.0) 281 CALL WDDSNX (WDMSFL, 282 M DSN) 283 IF (DSN.GT.0) THEN 284 CALL WDSCHK (WDMSFL,DSN,DSTYP, 285 O LREC,GRCNT,RETCOD) 286 IF (RETCOD.EQ.0) THEN 287 DSNCNT = DSNCNT + 1 288 DSNBUF(DSNCNT) = DSN 289 END IF 290 DSN = DSN + 1 291 END IF 292 END DO 293 END IF 294 write(*,*) 'MAIN: Analyzing',DSNCNT,' WDM data sets.' 295 write(*,*) 'MAIN: DSNs are ',(DSNBUF(I),I=1,DSNCNT) 296 END IF 297 298 IF (RETCOD .EQ. 0) THEN !run the analyses 299 write(*,*) 'MAIN:calling J407XE...' 300 C do analysis, reset dataset pointer to zero 301 DSNIND = 0 302 C set all other J407 common block variables 303 MOROPT(1)= 0 304 MOROPT(2)= 0 305 JOBTTL = ' ' 306 MSG1 = FOUT Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 7 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 307 INFIL2 = 5 308 C set printer plot file to FOUT 309 CALL PLTAPE (FOUT) 310 IF (UPDATEFG) THEN !write out verbose spec file 311 CALL WRITESPECIO (WDMSFL,INCRD,INFORM,FOUT,IPUNCH, 312 I IPLTOP,GRFMT,IPRTOP,IBCPUN,IDEBUG, 313 I CLSIZE,WEIBA,EMAOPT) 314 END IF 315 C do the analysis 316 CALL J407XE (MESSFL,WDMSFL,PAUSE,EMAOPT,UPDATEFG) 317 IF (UPDATEFG) THEN !update spec file with verbose version 318 CALL UPDATESPECFILE (SPCFUN,SPCFNM) 319 ELSE !just close spec file 320 CLOSE(SPCFUN) 321 END IF 322 END IF 323 C 324 999 CONTINUE 325 C get sent here if major problem encountered 326 IF (ZLNTXT(IOSTXT).GT.0) THEN 327 C write out IO Status text 328 WRITE(*,*) " IO Status: ",IOSTXT 329 END IF 330 C 331 CLOSE(MESSFL) 332 C 333 C close GKS 334 Ckmf gpclos closes unit 99 and then calls gclks. gclks 335 Ckmf (as well as later code in this program) may still 336 Ckmf want to write to 99. 337 Ckmf CALL GPCLOS (FE) 338 CALL GCLKS 339 C 340 C write out any errors read on input file and close output file 341 CALL JFLUSH (91,FOUT) 342 C 343 C don't see where output file is closed, try it here 344 INQUIRE(FOUT,NAME=FNAME) 345 write(*,*) "Closing output file " // FNAME 346 CLOSE(FOUT) 347 C 348 C CALL ANCLOS (MESSFL) 349 C 350 STOP 351 END Bytes of stack required for this program unit: 760. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 8 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- ALLSOM (INTEGER) scalar 44 (I1)4s (I1)7s 88= 149= ANINIZ SUBROUTINE 44u 61u APNAME (CHARACTER) scalar 30s (I2)17= BIGLOG (REAL) scalar 316 (I3)4s (I3)12s CLSIZE (REAL) scalar 40 (I3)3s (I3)11s 176r 313r 311r 311r 173r 173r CPAMP1 (REAL) scalar 344 (I3)6s (I3)14s CPAMP2 (REAL) scalar 348 (I3)6s (I3)14s CPAMP3 (REAL) scalar 352 (I3)6s (I3)14s CVRINT FUNCTION 38s 43u 192u 273u DOSTA (CHARACTER) array 48 (I1)4s (I1)9s DSN (INTEGER) scalar 29s 279= 280u 282r 281r 281r 283u 284r 284r 284r 288u 290u 290= DSNBMX (INTEGER) scalar (I4)6s (I4)7s (I4)9u DSNBUF (INTEGER) array 8 (I4)4s (I4)9s 273= 288= 295o DSNCNT (INTEGER) scalar 4 (I4)4s (I4)9s 275= 278= 287u 287= 288u 294o 295o DSNIND (INTEGER) scalar 0 (I4)4s (I4)9s 301= DSTYP (INTEGER) scalar 29s 277= 284r 284r 284r EMAOPT (INTEGER) scalar 27s 90= 176r 313r 311r 311r 316r 316r 316r 173r 173r EPS1 (REAL) scalar 320 (I3)5s (I3)13s EPS2 (REAL) scalar 324 (I3)5s (I3)13s FE (INTEGER) scalar 28s 64r 64r 64r FNAME (CHARACTER) scalar 32s (I2)19= 61r 61r 61r 344i 345u FOUT (INTEGER) scalar 27s 174r 306u 309r 311r 311r 311r 341r 341r 341r 344i 346i 173r 173r 309r 309r GCLKS SUBROUTINE 338u GPINIT SUBROUTINE 44u 66u GPOPEN SUBROUTINE 44u 64u GRCNT (INTEGER) scalar 29s 285r 284r 284r GRFMT (CHARACTER) scalar 348 (I1)4s (I1)8s 175r 312r 311r 311r 173r 173r GSMAX (REAL) scalar 32 (I3)3s (I3)11s GSMIN (REAL) scalar 28 (I3)3s (I3)11s HRECWO (REAL) scalar 328 (I3)5s (I3)13s HRECWS (REAL) scalar 336 (I3)5s (I3)13s HRECWX (REAL) scalar 332 (I3)5s (I3)13s I (INTEGER) scalar 26s 184= 185u 187u 189u 192u 205= 207u 207= 229u 229u 238u 238u 255u 255u 256o 257u 273u 273u 295= 295u 295u IBCPUN (INTEGER) scalar 4 (I1)2s (I1)5s 85= 175r 312r 311r 311r 173r 173r IDEBUG (INTEGER) scalar 12 (I1)2s (I1)5s 86= 175r 312r 311r 311r 173r 173r IMODFG (INTEGER) scalar 40 (I1)4s (I1)7s 87= INCRD (INTEGER) scalar 4 (I5)2s (I5)3s 170r 311r 311r 311r 169r 169r INDX1 (INTEGER) scalar 44 (I3)4s (I3)9s INDX2 (INTEGER) scalar 48 (I3)4s (I3)9s INDXPT (INTEGER) array 56 (I3)4s (I3)9s INFIL2 (INTEGER) scalar 12 (I5)2s (I5)3s 307= INFOERROR (INTEGER) scalar 40s INFORM (INTEGER) scalar 16 (I5)2s (I5)3s 170r 174r 270u 311r 311r 311r 169r 169r 173r 173r IOSNUM (INTEGER) scalar 26s 111i 117r 127i 137i 159i 267r IOSTXT (CHARACTER) scalar 33s 117r 267r 268o 268o 326r 326r 326r 328o 328o Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 9 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- IPEND (INTEGER) scalar 27s 155= 158u 164= 212u 220= IPLTOP (INTEGER) scalar 0 (I1)2s (I1)5s 83= 175r 312r 311r 311r 173r 173r IPPOS (INTEGER) scalar 16 (I1)2s (I1)5s 75= IPRTOP (INTEGER) scalar 8 (I1)2s (I1)5s 84= 175r 312r 311r 311r 173r 173r IPUNCH (INTEGER) scalar 8 (I5)2s (I5)3s 174r 311r 311r 311r 173r 173r ISKUDP (INTEGER) scalar 20 (I1)3s (I1)6s 76= ISTA (INTEGER) scalar 28s 154= 181u 181= 182u 183u 184u 186u 187u 194u 195u 197u 198u 201u 201u 204u 210u 211o 250u 251u 252u 253u 255u 257u IWXMOD (INTEGER) scalar 372 (I3)7s (I3)10s J (INTEGER) scalar 26s 186= 187u 190u 192u J407XE SUBROUTINE 43u 316u JFLUSH SUBROUTINE 43u 341u JOBTTL (CHARACTER) scalar 0 (I1)11s (I1)12s 305= K (INTEGER) scalar 26s 189= 190u 192u KWD (CHARACTER) scalar 33s 162= 167u 171u 178u 216= 217u 217u 217u 218u 224r 261u 167i 171i 178i 217i 217i 217i 217i 261i LFLAG (LOGICAL) scalar 35s 53= 54r 55r LGNAME (CHARACTER) scalar 31s (I2)18= 61r 61r 61r LNSPECS (INTEGER) scalar 28s 180= 225u 227u 228u 233u 233= 234o 235u 236u 237u 243u 249u 250u 251u 254u LREC (INTEGER) scalar 29s 285r 284r 284r LSPECS (CHARACTER) array 34s 227= 229= 238u 240= MESSFL (INTEGER) scalar (I6)8s (I6)10s 61u 316u 331u MOROPT (INTEGER) array 32 (I1)3s (I1)6s 303= 304= MSG (INTEGER) scalar 0 (I3)2s (I3)8s MSG1 (INTEGER) scalar 0 (I5)2s (I5)3s 306= MSL (INTEGER) scalar 4 (I3)2s (I3)8s MXINT (INTEGER) scalar (I7)1s (I7)2s (I3)9u (I3)12u NINDX (INTEGER) scalar 52 (I3)4s (I3)9s NOCLIM (INTEGER) scalar 24 (I3)2s (I3)8s NOCLM (INTEGER) scalar 28 (I1)3s (I1)6s 78= NOEPFC (INTEGER) scalar 20 (I3)2s (I3)8s NOPPOS (INTEGER) scalar 8 (I3)2s (I3)8s NOSYS (INTEGER) scalar 16 (I3)2s (I3)8s NOTRAN (INTEGER) scalar 12 (I3)2s (I3)8s NOXPA (INTEGER) scalar 24 (I1)3s (I1)6s 77= NSTA (INTEGER) scalar 28s 125= 131u 131= 146u 147o 148u 271u 272u 275u OPNINP SUBROUTINE 169u OPNOUT SUBROUTINE 173u PAUSE (INTEGER) scalar 27s 89= 316r 316r 316r PEAKFQBATCH Procedure 4s PLTAPE SUBROUTINE 309u RDOFLG (INTEGER) scalar 28s RETCOD (INTEGER) scalar 28s 170r 177r 285r 284r 284r 286u 298u 169r 169r 173r 173r RMSDGS (REAL) scalar 340 (I3)6s (I3)14s S (CHARACTER) scalar 33s 127i 127i 128u 129r 130u 142o 142o 159i 159i 160r 161r 162r 162r 162r 168r 170r 172r 174r 179r 182r 204r 213i 213i 214r 215r 216r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 10 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 216r 216r 224r 224= 242r 243u 129r 129r 130i 161r 161r 169r 169r 173r 173r 214r 214r SIGHOT (REAL) scalar 360 (I3)7s (I3)15s SIGLOT (REAL) scalar 356 (I3)7s (I3)15s SPCFNM (CHARACTER) scalar 33s 110r 111i 113o 113o 118o 118o 318r 318r 318r SPCFUN (INTEGER) scalar 20 (I5)2s (I5)3s 108= 111i 127i 137i 159i 213i 318r 318r 318r 320i SPECS (TYPE (SPEC)) array 250= SPECS (CHARACTER) array 34s 229u 231= 235= 238= 243= 255u 259= STAIND (INTEGER) scalar 26s 192= 193u 195o 198o STASPECS (TYPE (STASPEC)) array 13s 148= 182= 186r 186r 186r 187u 187u 189r 189r 189r 192r 192r 192r 194o 194o 195r 197o 197o 198r 201r 201= 204o 204o 210u 251= 252o 253o 253o 255= 257r 273r 273r 273r 187i 187i STRRETREM FUNCTION 39s 43u 162u 216u TXPROB (REAL) array 184 (I3)4s (I3)12s UPCASE SUBROUTINE 129u 161u 214u UPDATEFG (LOGICAL) scalar 13s 69= 263= 310u 316r 316r 316r 317u UPDATESPECFILE SUBROUTINE 44u 318u VERSN (CHARACTER) scalar 32s (I2)2= (I2)3= (I2)4= (I2)5= (I2)6= (I2)7= (I2)8= (I2)9= (I2)10= (I2)11= (I2)12= (I2)13= (I2)14= WCXAUX (REAL) array 364 (I3)7s (I3)15s WDBOPN Procedure 43u WDDSNX SUBROUTINE 45u 281u WDMSFL (INTEGER) scalar 27s 170r 281r 281r 281r 284r 284r 284r 311r 311r 311r 316r 316r 316r 169r 169r WDSCHK SUBROUTINE 45u 284u WEIBA (REAL) scalar 36 (I3)3s (I3)11s 81= 176r 313r 311r 311r 173r 173r WRITESPECIO SUBROUTINE 44u 311u WSKLAT (REAL) scalar 312 (I3)4s (I3)12s ZLNTXT FUNCTION 38s 43u 186u 189u 326u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 127g 134s 20 137g 141s 30 139g 144s 70 228d 230s 80 237d 239s 90 213g 247s 100 254d 258s 120 159g 266s 150 272d 274s 999 119g 324s 5 111g 116s 8 114g 121s 1000 48s 127f 159f 213f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 11 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE OPNINP Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 352 C 353 C 354 C 355 SUBROUTINE OPNINP 356 M ( ISTR, WDMSFL, INCRD, 357 O INFORM, RETCOD ) 358 C 359 C + + + PURPOSE + + + 360 C Get peak flow data for input 361 C 362 C + + + HISTORY + + + 363 C updated for batch version of PEAKFQ, 9/03 364 C Paul Hummel of AQUA TERRA Consultants 365 C 366 C + + + DUMMY ARGUMENTS + + + 367 INTEGER WDMSFL, INCRD, 368 $ INFORM, RETCOD 369 CHARACTER*80 ISTR 370 C 371 C + + + ARGUMENT DEFINITIONS + + + 372 C ISTR - input specification string from batch input file 373 C WDMSFL - Fortran unit number of wdm file containing/for peak data 374 C INCRD - Fortran unit number for Watstore card-image input 375 C INFORM - indicator flag 376 C 1 - input from wdm file or terminal 377 C 2 - input from file containing WATSTORE card-image format 378 C RETCOD - 379 C 380 C + + + COMMON BLOCKS + + + 381 INCLUDE 'cpkdsn.inc' 382 C 383 C + + + LOCAL VARIABLES + + + 384 Cprh INTEGER L0, L1, IDCNT, IDLEN(20), IDLNG 385 CHARACTER*64 WDMNAME 386 CHARACTER*80 KWD 387 C 388 C + + + FUNCTIONS + + + 389 CHARACTER*80 STRRETREM 390 C 391 C + + + EXTERNALS + + + 392 EXTERNAL STRRETREM, WDBOPN 393 C 394 C DATA INITIALIZATIONS + + + 395 Cprh DATA IDCNT, IDLEN, IDLNG, L0, L1 396 Cprh $ / 20, 20*15, 300, 0, 1 / 397 C 398 C + + + END SPECIFICATIONS + + + 399 C 400 RETCOD = 0 401 C 402 C input options: WDM, ASCII FILE 403 KWD = STRRETREM(ISTR) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 12 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 404 IF (KWD.EQ.'WDM') THEN 405 C input peak data from wdm file 406 WDMSFL = 12 407 WDMNAME= TRIM(ISTR(1:64)) 408 CALL WDBOPN (WDMSFL,WDMNAME,0, 409 O IRET) 410 IF (IRET.EQ.0) THEN !successful open of WDM file 411 WRITE(*,*) "OPNINP:Successful Open WDM file:'" 412 $ // WDMNAME // "'" 413 Cprh IDATA = 1 414 INFORM = 1 415 ELSE !WDM file not opened 416 !LOG IT 417 WRITE(*,*) "OPNINP:FAILED open of WDM file'" 418 $ // WDMNAME // "'" 419 END IF 420 ELSE IF (KWD.EQ.'ASCI') THEN 421 C input peak data from WATSTORE formatted file 422 INCRD = 13 423 OPEN(INCRD,ISTR,ERR=10) 424 C successful open of Watstore file 425 WRITE(*,*) "OPNINP:Successful Open Watstore file:'" 426 $ // TRIM(ISTR) // "'" 427 428 Cprh IDATA = 3 429 INFORM = 2 430 GO TO 20 431 432 10 CONTINUE !get here on error opening Watstore file 433 !LOG IT 434 WRITE(*,*) "OPNINP:FAILED open of Watstore file'" 435 $ // TRIM(ISTR) // "'" 436 Cprh IDATA = 0 437 438 20 CONTINUE 439 440 END IF 441 C 442 RETURN 443 END Bytes of stack required for this program unit: 496. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- DSNBMX (INTEGER) scalar (I4)6s (I4)7s (I4)9u DSNBUF (INTEGER) array 8 (I4)4s (I4)9s DSNCNT (INTEGER) scalar 4 (I4)4s (I4)9s DSNIND (INTEGER) scalar 0 (I4)4s (I4)9s INCRD (INTEGER) scalar 356s 367s 422= 423i Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 13 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- INFORM (INTEGER) scalar 357s 368s 414= 429= IRET (INTEGER) scalar 409r 408r 408r 410u ISTR (CHARACTER) scalar 356s 369s 403r 403r 403r 407r 423i 426r 435r KWD (CHARACTER) scalar 386s 403= 404u 420u 404i 420i OPNINP SUBROUTINE 355s RETCOD (INTEGER) scalar 357s 368s 400= STRRETREM FUNCTION 389s 392u 403u WDBOPN SUBROUTINE 392u 408u WDMNAME (CHARACTER) scalar 385s 407= 408r 408r 408r 412u 418u WDMSFL (INTEGER) scalar 356s 367s 406= 408r 408r 408r -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 423g 432s 20 430g 438s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 14 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE OPNOUT Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 444 C 445 C 446 C 447 SUBROUTINE OPNOUT 448 I ( ISTR, INFORM, 449 M FOUT, IPUNCH, 450 M IPLTOP, GRFMT, IPRTOP, IBCPUN, IDEBUG, 451 M CLSIZE, WEIBA, EMAOPT, 452 O RETCOD ) 453 C 454 C + + + PURPOSE + + + 455 C Modify processing options. 456 C 457 C + + + HISTORY + + + 458 C updated for batch version of PEAKFQ, 9/03 459 C Paul Hummel of AQUA TERRA Consultants 460 C 461 C + + + DUMMY ARGUMENTS + + + 462 INTEGER INFORM, FOUT, IPUNCH, EMAOPT, 463 $ IPLTOP, IPRTOP, IBCPUN, IDEBUG, RETCOD 464 REAL CLSIZE, WEIBA 465 CHARACTER*3 GRFMT 466 CHARACTER*80 ISTR 467 C 468 C + + + ARGUMENT DEFINITIONS + + + 469 C ISTR - input specification string from batch input file 470 C INFORM - ??? 471 C FOUT - ??? 472 C IPUNCH - ??? 473 C IPLTOP - ??? 474 C GRFMT - format of graphic file (BMP, CGM, or WMF) 475 C IPRTOP - ??? 476 C IBCPUN - ??? 477 C IDEBUG - ??? 478 C CLSIZE - ??? 479 C WEIBA - ??? 480 C EMAOPT - flag for performing EMA analysis (0 - no, 1 - yes) 481 C RETCOD - ??? 482 C 483 C + + + LOCAL VARIABLES + + + 484 Cprh INTEGER AGAIN, RTCMND 485 Cprh $ I, L0, LEN1, LEN2, LEN5 486 CHARACTER*1 ISTR1(80) 487 CHARACTER*80 KWD 488 C 489 C + + + FUNCTIONS + + + 490 INTEGER IYESNO, ZLNTXT 491 REAL CHRDEC 492 CHARACTER*80 STRRETREM 493 C 494 C + + + INTRINSICS + + + 495 INTRINSIC MOD Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 15 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 496 C 497 C + + + EXTERNALS + + + 498 EXTERNAL IYESNO, ZLNTXT, STRRETREM, CVARAR, CHRDEC 499 C 500 C + + + DATA INITIALIZATIONS + + + 501 Cprh DATA SCLU, L0, LEN1, LEN2, LEN5 502 Cprh $ / 121, 0, 1, 2, 5 / 503 C 504 C + + + END SPECIFICATIONS + + + 505 C 506 C input options: FILE, OPTIONS 507 KWD = STRRETREM(ISTR) 508 IF (KWD.EQ.'FILE') THEN 509 FOUT = 14 510 OPEN (FOUT,FILE=ISTR,ERR=10) 511 C successful open of output file 512 !LOG IT 513 WRITE(*,*) "OPENOUT:Opened Output File:'" 514 $ // TRIM(ISTR) // "'" 515 GO TO 20 516 517 10 CONTINUE !get here on error opening output file 518 FOUT = 0 519 !LOG IT 520 WRITE(*,*) "OPENOUT:FAILED to Open Output File:'" 521 $ // TRIM(ISTR) // "'" 522 523 20 CONTINUE 524 525 ELSE IF (KWD.EQ.'PLOT') THEN !get next plot keyword 526 WRITE(*,*) "OPNOUT:PLOT:'" // TRIM(ISTR) // "'" 527 KWD = STRRETREM(ISTR) 528 IF (KWD.EQ.'STYLE') THEN 529 WRITE(*,*) "OPNOUT:PLOT:STYLE:'" // TRIM(ISTR) // "'" 530 IF (ISTR.EQ.'GRAPHICS') THEN 531 WRITE(*,*) "OPNOPT:PLOT:STYLE:GRAPHICS" 532 IPLTOP = 1 533 ELSE IF (ISTR.EQ.'PRINTER') THEN 534 WRITE(*,*) "OPNOPT:PLOT:STYLE:PRINTER" 535 IPLTOP = 2 536 ELSE IF (ISTR.EQ.'BOTH') THEN 537 WRITE(*,*) "OPNOPT:PLOT:STYLE:BOTH" 538 IPLTOP = 3 539 ELSE 540 WRITE(*,*) "OPNOPT:PLOT:STYLE:NONE" 541 IPLTOP = 0 542 END IF 543 ELSE IF (KWD.EQ.'FORMAT') THEN 544 GRFMT = TRIM(ISTR) 545 IF (GRFMT.NE.'BMP' .AND. GRFMT.NE.'CGM' .AND. 546 $ GRFMT(1:2).NE.'PS' .AND. GRFMT.NE.'WMF') THEN 547 C not a valid graphic format Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 16 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 548 WRITE(*,*) "OPNOUT:PLOT:FORMAT: Graphic Format '" // 549 $ GRFMT //"' unknown - NO GRAPHIC PLOTS" 550 GRFMT = '' 551 END IF 552 ELSE IF (KWD.EQ.'PRINTPOS') THEN 553 IPRTOP = IYESNO(ISTR,1) 554 ELSE IF (KWD.EQ.'POSITION') THEN 555 ILEN = ZLNTXT(ISTR) 556 IF (ILEN.GT.0) THEN 557 CALL CVARAR (ILEN,ISTR,ILEN,ISTR1) 558 WEIBA = CHRDEC(ILEN,ISTR1) 559 IF (WEIBA.LT.0.0 .OR. WEIBA.GT.1.0) THEN 560 !LOG IT 561 END IF 562 END IF 563 END IF 564 ELSE IF (KWD.EQ.'ADDITIONAL') THEN 565 IF (ISTR(1:3).EQ.'WDM') THEN 566 IBCPUN = 1 567 ELSE IF (ISTR(1:3).EQ.'WAT') THEN 568 IBCPUN = 2 569 ELSE IF (ISTR(1:3).EQ.'BOT') THEN 570 IBCPUN = 3 571 ELSE 572 IBCPUN = 0 573 END IF 574 write(*,*) "Processing ADDITIONAL: IBCPUN ",IBCPUN 575 IF (IBCPUN.GE.2) THEN !open output Watstore basin characteristics file 576 KWD = STRRETREM(ISTR) 577 write(*,*) "Processing ADDITIONAL: KWD,ISTR : " 578 $ // TRIM(KWD) // ", " // TRIM(ISTR) 579 IF (ZLNTXT(ISTR).GT.0) THEN !file name should be remaining text 580 IPUNCH = 15 581 OPEN (IPUNCH,FILE=ISTR,ERR=30) 582 C successful open of output basin characteristics file 583 !LOG IT 584 WRITE(*,*) "OPENOUT:Opened Watstore BCD File: '" 585 $ // TRIM(ISTR) // "'" 586 GO TO 40 587 588 30 CONTINUE !get here on error opening output file 589 !LOG IT 590 WRITE(*,*) "OPENOUT:FAILED to Open Watstore BCD File:'" 591 $ // TRIM(ISTR) // "'" 592 C dummy default (following old code, prh 8/03) 593 IPUNCH = 7 594 595 40 CONTINUE 596 ELSE !no file name 597 WRITE(*,*) "OPENOUT: No Watstrore File Name specified!!!" 598 IBCPUN = IBCPUN - 2 599 END IF Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 17 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 600 END IF 601 602 ELSE IF (KWD.EQ.'DEBUG') THEN 603 IDEBUG = IYESNO(ISTR,1) 604 ELSE IF (KWD.EQ.'EMA') THEN 605 EMAOPT = IYESNO(ISTR,1) 606 ELSE IF (KWD.EQ.'CONFIDENCE') THEN 607 ILEN = ZLNTXT(ISTR) 608 IF (ILEN.GT.0) THEN 609 CALL CVARAR (ILEN,ISTR,ILEN,ISTR1) 610 CLSIZE = CHRDEC(ILEN,ISTR1) 611 END IF 612 END IF 613 C check specs 614 IF (INFORM.EQ.0) THEN !should specify input specs before output specs 615 !LOG IT 616 END IF 617 IF (MOD(IBCPUN,2) .EQ. 1) THEN 618 C WDM or BOTH for output 619 IF (INFORM .NE. 1) THEN 620 C but input not from WDM 621 !LOG IT 622 IBCPUN = IBCPUN - 1 623 END IF 624 END IF 625 C 626 RETURN 627 END Bytes of stack required for this program unit: 520. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- CHRDEC FUNCTION 491s 498u 558u 610u CLSIZE (REAL) scalar 451s 464s 610= CVARAR SUBROUTINE 498u 557u 609u EMAOPT (INTEGER) scalar 451s 462s 605= FOUT (INTEGER) scalar 449s 462s 509= 510i 518= GRFMT (CHARACTER) scalar 450s 465s 544= 545u 545u 546u 546u 549u 550= 545i 545i 545i 545i IBCPUN (INTEGER) scalar 450s 463s 566= 568= 570= 572= 574o 575u 598u 598= 617r 622u 622= IDEBUG (INTEGER) scalar 450s 463s 603= ILEN (INTEGER) scalar 555= 556u 557r 557r 557r 557r 557r 557r 558r 558r 558r 607= 608u 609r 609r 609r 609r 609r 609r 610r 610r 610r INFORM (INTEGER) scalar 448s 462s 614u 619u IPLTOP (INTEGER) scalar 450s 463s 532= 535= 538= 541= IPRTOP (INTEGER) scalar 450s 463s 553= IPUNCH (INTEGER) scalar 449s 462s 580= 581i 593= Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 18 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- ISTR (CHARACTER) scalar 448s 466s 507r 507r 507r 510i 514r 521r 526r 527r 527r 527r 529r 530u 533u 536u 544r 553r 553r 553r 555r 555r 555r 557r 557r 557r 565u 567u 569u 576r 576r 576r 578r 579r 579r 579r 581i 585r 591r 603r 603r 603r 605r 605r 605r 607r 607r 607r 609r 609r 609r 530i 533i 536i 565i 567i 569i ISTR1 (CHARACTER) array 486s 557r 557r 557r 558r 558r 558r 609r 609r 609r 610r 610r 610r IYESNO FUNCTION 490s 498u 553u 603u 605u KWD (CHARACTER) scalar 487s 507= 508u 525u 527= 528u 543u 552u 554u 564u 576= 578r 602u 604u 606u 508i 525i 528i 543i 552i 554i 564i 602i 604i 606i OPNOUT SUBROUTINE 447s RETCOD (INTEGER) scalar 452s 463s STRRETREM FUNCTION 492s 498u 507u 527u 576u WEIBA (REAL) scalar 451s 464s 558= 559u 559u ZLNTXT FUNCTION 490s 498u 555u 579u 607u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 510g 517s 20 515g 523s 30 581g 588s 40 586g 595s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 19 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PARSESTASPECS Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 628 C 629 C 630 C 631 SUBROUTINE PARSESTASPECS 632 I (STAID,XSYSPK,XHSTPK, 633 M GENSKU,HISTPD,QHIOUT,QLWOUT, 634 M GAGEB,RMSEGS,IBEGYR,IENDYR, 635 M ISKUOP,IKROPT,FLAT,FLONG) 636 C 637 C + + + PURPOSE + + + 638 C Parse driver input file records into station computational options 639 C 640 C + + + HISTORY + + + 641 C created for batch version of PEAKFQ, 9/03 642 C Paul Hummel of AQUA TERRA Consultants 643 C 644 USE CompSpecs 645 C 646 C + + + DUMMY ARGUMENTS + + + 647 INTEGER IBEGYR, IENDYR, ISKUOP, IKROPT 648 REAL XSYSPK, XHSTPK, GENSKU, HISTPD, QHIOUT, QLWOUT, 649 $ GAGEB, RMSEGS, FLAT, FLONG 650 CHARACTER*(*) STAID 651 C 652 C + + + ARGUMENT DEFINITIONS + + + 653 C STAID - Station ID being processed 654 C XSYSPK - highest systematic peak 655 C XHSTPK - lowest historic peak 656 C GENSKU - generalized skew 657 C HISTPD - length of historic period 658 C QHIOUT - hi-outlier threshold 659 C QLWOUT - lo-outlier threshold 660 C GAGEB - gage base discharge 661 C RMSEGS - standard error of generalized skew 662 C IBEGYR - beginning year of analysis 663 C IENDYR - ending year of analysis 664 C ISKUOP - skew computation option, 665 C -1 - Station 666 C 0 - Weighted 667 C 1 - Generalized 668 C IKROPT - allow urban/regularized peaks (0 - no, 1 -yes) 669 C FLAT - station latitude, decimal 670 C FLONG - station longitude, decimal 671 C 672 C + + + LOCAL VARIABLES 673 INTEGER I,ISTA,NSPECS 674 CHARACTER*80 S,KWD 675 C 676 C + + + FUNCTIONS + + + 677 INTEGER CVRINT, IYESNO 678 REAL CVRDEC 679 CHARACTER*80 STRRETREM Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 20 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 680 C 681 C + + + EXTERNALS + + + 682 EXTERNAL CVRINT, IYESNO, CVRDEC, STRRETREM, WRITESPECSTA 683 C 684 C + + + END SPECIFICATIONS + + + 685 C 686 NSPECS = -1 !assume no specs for this station 687 C 688 IF (ALLOCATED(STASPECS)) THEN !station specs exist 689 ISTA = 1 690 DO WHILE (ISTA .LE. UBOUND(STASPECS,1) .AND. 691 $ NSPECS.LT.0) 692 write(*,*)"PARSESTASPECS: STASPECS,STAID ", 693 $ STASPECS(ISTA)%ID,STAID 694 IF (STASPECS(ISTA)%ID .EQ. STAID) THEN !specs exist for this station 695 NSPECS = STASPECS(ISTA)%NSPECS 696 c ISTA = UBOUND(STASPECS,1) 697 ELSE 698 ISTA = ISTA + 1 699 END IF 700 END DO 701 ELSE !use defaults 702 WRITE(*,*) "Using default Specs for Station: ",STAID 703 END IF 704 705 IF (NSPECS .GT. 0) THEN 706 DO 100 I = 1, NSPECS 707 S = STASPECS(ISTA)%SPECS(I)%STR 708 KWD = STRRETREM(S) 709 IF (KWD .EQ. 'GENSKEW') THEN 710 GENSKU = CVRDEC(S) 711 ELSE IF (KWD .EQ. 'SKEWSE') THEN 712 RMSEGS = CVRDEC(S) 713 ELSE IF (KWD .EQ. 'BEGYEAR') THEN 714 IBEGYR = CVRINT(S) 715 ELSE IF (KWD .EQ. 'ENDYEAR') THEN 716 IENDYR = CVRINT(S) 717 ELSE IF (KWD .EQ. 'HISTPERIOD') THEN 718 HISTPD = CVRDEC(S) 719 ELSE IF (KWD .EQ. 'SKEWOPT') THEN 720 IF (S .EQ. 'STATION') THEN 721 ISKUOP = -1 722 ELSE IF (S .EQ. 'WEIGHTED') THEN 723 ISKUOP = 0 724 ELSE IF (S .EQ. 'GENERALIZED') THEN 725 ISKUOP = 1 726 END IF 727 ELSE IF (KWD .EQ. 'URB/REG') THEN 728 IKROPT = IYESNO(S,0) 729 ELSE IF (KWD .EQ. 'LOTHRESH') THEN 730 QLWOUT = CVRDEC(S) 731 ELSE IF (KWD .EQ. 'HITHRESH') THEN Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 21 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 732 QHIOUT = CVRDEC(S) 733 ELSE IF (KWD .EQ. 'GAGEBASE') THEN 734 GAGEB = CVRDEC(S) 735 ELSE IF (KWD .EQ. 'LATITUDE') THEN 736 FLAT = CVRDEC(S) 737 ELSE IF (KWD .EQ. 'LONGITUDE') THEN 738 FLONG = CVRDEC(S) 739 END IF 740 100 CONTINUE 741 END IF 742 C 743 IF (UPDATEFG) THEN 744 CALL WRITESPECSTA (STAID,GENSKU,HISTPD,QHIOUT,QLWOUT, 745 I GAGEB,RMSEGS,IBEGYR,IENDYR, 746 I ISKUOP,IKROPT,FLAT,FLONG,XSYSPK,XHSTPK) 747 END IF 748 C 749 RETURN 750 END Bytes of stack required for this program unit: 352. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- CVRDEC FUNCTION 678s 682u 710u 712u 718u 730u 732u 734u 736u 738u CVRINT FUNCTION 677s 682u 714u 716u FLAT (REAL) scalar 635s 649s 736= 746r 744r 744r FLONG (REAL) scalar 635s 649s 738= 746r 744r 744r GAGEB (REAL) scalar 634s 649s 734= 745r 744r 744r GENSKU (REAL) scalar 633s 648s 710= 744r 744r 744r HISTPD (REAL) scalar 633s 648s 718= 744r 744r 744r I (INTEGER) scalar 673s 707u IBEGYR (INTEGER) scalar 634s 647s 714= 745r 744r 744r IENDYR (INTEGER) scalar 634s 647s 716= 745r 744r 744r IKROPT (INTEGER) scalar 635s 647s 728= 746r 744r 744r ISKUOP (INTEGER) scalar 635s 647s 721= 723= 725= 746r 744r 744r ISTA (INTEGER) scalar 673s 689= 690u 693u 694u 695u 698u 698= 707u IYESNO FUNCTION 677s 682u 728u KWD (CHARACTER) scalar 674s 708= 709u 711u 713u 715u 717u 719u 727u 729u 731u 733u 735u 737u 709i 711i 713i 715i 717i 719i 727i 729i 731i 733i 735i 737i NSPECS (INTEGER) scalar 673s 686= 691u 695= 705u 706u PARSESTASPECS SUBROUTINE 631s QHIOUT (REAL) scalar 633s 648s 732= 744r 744r 744r QLWOUT (REAL) scalar 633s 648s 730= 744r 744r 744r RMSEGS (REAL) scalar 634s 649s 712= 745r 744r 744r S (CHARACTER) scalar 674s 707= 708r 708r 708r 710r 710r 710r 712r 712r 712r 714r 714r 714r 716r 716r 716r 718r 718r 718r 720u 722u 724u 728r 728r 728r 730r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 22 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 730r 730r 732r 732r 732r 734r 734r 734r 736r 736r 736r 738r 738r 738r 720i 722i 724i STAID (CHARACTER) scalar 632s 650s 693o 693o 694u 702o 702o 744r 744r 744r 694i STASPECS (TYPE (STASPEC)) array 644s 688r 690r 693o 693o 694u 695u 707u 694i STRRETREM FUNCTION 679s 682u 708u UPDATEFG (LOGICAL) scalar 644s 743u WRITESPECSTA SUBROUTINE 682u 744u XHSTPK (REAL) scalar 632s 648s 746r 744r 744r XSYSPK (REAL) scalar 632s 648s 746r 744r 744r -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 100 706d 740s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 23 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. FUNCTION DOSTATION Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 751 C 752 C 753 C 754 LOGICAL FUNCTION DOSTATION 755 I (ISTART, 756 M STAID) 757 C 758 C + + + PURPOSE + + + 759 C Determine whether or not a station is to be processed. 760 C STAID may be updated with an index if multiple 761 C instances of the same station are found. 762 C 763 C + + + HISTORY + + + 764 C created for batch version of PEAKFQ, 9/03 765 C Paul Hummel of AQUA TERRA Consultants 766 C 767 USE CompSpecs 768 C 769 C + + + DUMMY ARGUMENTS + + + 770 INTEGER ISTART 771 CHARACTER*(*) STAID 772 C 773 C + + + ARGUMENT DEFINITIONS + + + 774 C ISTART - flag for start of processing a data file 775 C 0 - start of file 776 C >0 - after start of file 777 C STAID - Station ID being read 778 C 779 C + + + SAVES + + + 780 SAVE NSTAUSED,STAUSED 781 C 782 C + + + LOCAL VARIABLES 783 INTEGER ISTA,NSTAUSED,J,K,STAIND 784 LOGICAL LDO 785 CHARACTER*18 STAUSED(1000) 786 C 787 C + + + FUNCTIONS + + + 788 INTEGER ZLNTXT, CVRINT 789 C 790 C + + + DATA INITIALIZATIONS + + + 791 DATA NSTAUSED/0/ 792 C 793 C + + + END SPECIFICATIONS + + + 794 C 795 IF (ISTART.EQ.0 .AND. NSTAUSED.GT.0) THEN 796 C starting to process a new data file, re-init station used array 797 DO 10 I = 1,NSTAUSED 798 STAUSED(I) = " " 799 10 CONTINUE 800 NSTAUSED = 0 801 END IF 802 C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 24 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 803 LDO = .FALSE. !assume not doing this station 804 IF (ALLOCATED(STASPECS)) THEN !station specs exist 805 IF (NSTAUSED.GT.0) THEN !look through stations used so far 806 ISTA = NSTAUSED 807 DO WHILE (ISTA.GT.0) 808 J = ZLNTXT(STAID) 809 IF (STAUSED(ISTA)(1:J).EQ.STAID) THEN 810 C same station ID, increment STAID index 811 K = ZLNTXT(STAUSED(ISTA)) 812 IF (K.GT.J) THEN 813 C this station already has an index, increment it 814 STAIND = CVRINT(STAUSED(ISTA)(J+2:K)) + 1 815 IF (STAIND.LT.10) THEN 816 WRITE(STAID,'(I1)') STAID // "-",STAIND 817 ELSE 818 WRITE(STAID,'(I2)') STAID // "-",STAIND 819 END IF 820 ELSE !first duplicate of this station 821 STAID = TRIM(STAID) // "-1" 822 END IF 823 WRITE(*,*) "DOSTATION: Duplicate Station ID: look for ", 824 $ TRIM(STAID) 825 ISTA = 0 !exit loop 826 END IF 827 ISTA = ISTA - 1 828 END DO 829 END IF 830 831 C update station used info 832 NSTAUSED = NSTAUSED + 1 833 STAUSED(NSTAUSED) = STAID 834 835 C now look for the station in the STASPECS array 836 ISTA = 1 837 DO WHILE (ISTA .LE. UBOUND(STASPECS,1)) 838 IF (STASPECS(ISTA)%ID .EQ. STAID) THEN !Yes, do this station 839 LDO = .TRUE. 840 ISTA = UBOUND(STASPECS,1) 841 END IF 842 ISTA = ISTA + 1 843 END DO 844 END IF 845 C 846 DOSTATION = LDO 847 C 848 RETURN 849 END Bytes of stack required for this program unit: 144. Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 25 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- CVRINT FUNCTION 788s 814u DOSTATION (LOGICAL) scalar 754s 846= DOSTATION FUNCTION 754s I (INTEGER) scalar 798u ISTA (INTEGER) scalar 783s 806= 807u 809u 811u 814u 825= 827u 827= 836= 837u 838u 840= 842u 842= ISTART (INTEGER) scalar 755s 770s 795u J (INTEGER) scalar 783s 808= 809u 812u 814u K (INTEGER) scalar 783s 811= 812u 814u LDO (LOGICAL) scalar 784s 803= 839= 846u NSTAUSED (INTEGER) scalar 780s 783s 791/ 795u 797u 800= 805u 806u 832u 832= 833u STAID (CHARACTER) scalar 756s 771s 808r 808r 808r 809u 816o 816o 816u 818o 818o 818u 821r 821= 824r 833u 838u 809i 838i STAIND (INTEGER) scalar 783s 814= 815u 816o 818o STASPECS (TYPE (STASPEC)) array 767s 804r 837r 838u 840r 838i STAUSED (CHARACTER) array 780s 785s 798= 809u 811r 811r 811r 814r 814r 814r 833= 809i UPDATEFG (LOGICAL) scalar 767s ZLNTXT FUNCTION 788s 808u 811u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 797d 799s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 26 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE WRITESPECIO Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 850 C 851 C 852 C 853 SUBROUTINE WRITESPECIO (WDMSFL,INCRD,INFORM,FOUT,IPUNCH, 854 I IPLTOP,GRFMT,IPRTOP,IBCPUN,IDEBUG, 855 I CLSIZE,WEIBA,EMAOPT) 856 C 857 C + + + PURPOSE + + + 858 C Write out verbose version of spec file (i.e. include 859 C a record for every spec, even if defaulted). 860 C This routine opens a temporary spec file and 861 C writes Input and Output specs to it. 862 C Station specs are written in WRITESPECSTA. 863 C 864 C + + + HISTORY + + + 865 C created for batch version of PEAKFQ, 1/04 866 C Paul Hummel of AQUA TERRA Consultants 867 C 868 C + + + DUMMY ARGUMENTS + + + 869 INTEGER WDMSFL,INCRD,INFORM,FOUT,IPUNCH,EMAOPT, 870 $ IPLTOP,IPRTOP,IBCPUN,IDEBUG 871 REAL CLSIZE,WEIBA 872 CHARACTER*3 GRFMT 873 C 874 C + + + ARGUMENT DEFINITIONS + + + 875 C WDMSFL - Fortran unit number for WDM input file 876 C INCRD - Fortran unit number for ASCI input file 877 C 878 C + + + LOCAL VARIABLES + + + 879 CHARACTER*80 FNAME 880 C 881 C + + + END SPECIFICATIONS + + + 882 C 883 write(99,*) 'Updating spec file I/O options' 884 OPEN (UNIT=92,FILE='TEMPSPEC',STATUS='REPLACE') 885 WRITE(92,*) 'VERBOSE' 886 C input file 887 IF (INFORM.EQ.1) THEN !WDM file 888 INQUIRE(WDMSFL,NAME=FNAME) 889 WRITE(92,*) 'I WDM '//TRIM(FNAME) 890 ELSE !ASCII file 891 INQUIRE(INCRD,NAME=FNAME) 892 WRITE(92,*) 'I ASCI '//TRIM(FNAME) 893 END IF 894 C output file 895 INQUIRE(FOUT,NAME=FNAME) 896 WRITE(92,*) 'O File '//TRIM(FNAME) 897 C plot style and other plot options 898 IF (IPLTOP.LE.0) THEN 899 WRITE(92,*) 'O Plot Style None' 900 ELSE IF (IPLTOP.EQ.1) THEN 901 WRITE(92,*) 'O Plot Style Graphics' Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 27 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 902 ELSE IF (IPLTOP.EQ.2) THEN 903 WRITE(92,*) 'O Plot Style Printer' 904 ELSE IF (IPLTOP.EQ.3) THEN 905 WRITE(92,*) 'O Plot Style Both' 906 END IF 907 IF ((IPLTOP.EQ.1 .OR. IPLTOP.EQ.3) .AND. GRFMT.NE.'') THEN 908 C also write out graphic format 909 WRITE(92,*) '0 Plot Format '//GRFMT 910 END IF 911 IF (IPRTOP.EQ.1) THEN 912 WRITE(92,*) 'O Plot PrintPos Yes' 913 ELSE 914 WRITE(92,*) 'O Plot PrintPos No' 915 END IF 916 WRITE(92,*) 'O Plot Position ',WEIBA 917 C additional output 918 IF (IBCPUN.GE.2) THEN 919 INQUIRE(IPUNCH,NAME=FNAME) 920 END IF 921 IF (IBCPUN.EQ.0) THEN 922 WRITE(92,*) 'O Additional None' 923 ELSE IF (IBCPUN.EQ.1) THEN 924 WRITE(92,*) 'O Additional WDM' 925 ELSE IF (IBCPUN.EQ.2) THEN 926 WRITE(92,*) 'O Additional WAT '//TRIM(FNAME) 927 ELSE IF (IBCPUN.EQ.3) THEN 928 WRITE(92,*) 'O Additional Both '//TRIM(FNAME) 929 END IF 930 IF (IDEBUG.EQ.1) THEN 931 WRITE(92,*) 'O Debug Yes' 932 ELSE 933 WRITE(92,*) 'O Debug No' 934 END IF 935 IF (EMAOPT.EQ.1) THEN 936 WRITE(92,*) 'O EMA Yes' 937 ELSE 938 WRITE(92,*) 'O EMA No' 939 END IF 940 WRITE(92,*) 'O Confidence ',CLSIZE 941 C 942 RETURN 943 END Bytes of stack required for this program unit: 88. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- CLSIZE (REAL) scalar 855s 871s 940o EMAOPT (INTEGER) scalar 855s 869s 935u FNAME (CHARACTER) scalar 879s 888i 889r 891i 892r 895i 896r 919i 926r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 28 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 928r FOUT (INTEGER) scalar 853s 869s 895i GRFMT (CHARACTER) scalar 854s 872s 907u 909u 907i IBCPUN (INTEGER) scalar 854s 870s 918u 921u 923u 925u 927u IDEBUG (INTEGER) scalar 854s 870s 930u INCRD (INTEGER) scalar 853s 869s 891i INFORM (INTEGER) scalar 853s 869s 887u IPLTOP (INTEGER) scalar 854s 870s 898u 900u 902u 904u 907u 907u IPRTOP (INTEGER) scalar 854s 870s 911u IPUNCH (INTEGER) scalar 853s 869s 919i WDMSFL (INTEGER) scalar 853s 869s 888i WEIBA (REAL) scalar 855s 871s 916o WRITESPECIO SUBROUTINE 853s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 29 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE WRITESPECSTA Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 944C 945C 946C 947 SUBROUTINE WRITESPECSTA 948 I (STAID,GENSKU,HISTPD,QHIOUT,QLWOUT, 949 M GAGEB,RMSEGS,IBEGYR,IENDYR, 950 M ISKUOP,IKROPT,FLAT,FLONG,XSYSPK,XHSTPK) 951C 952C + + + PURPOSE + + + 953C Write out verbose version of spec file (i.e. include 954C a record for every spec, even if defaulted). 955C This routine writes station specs to the 956C temporary spec file opened in WRITESPECIO. 957C 958C + + + HISTORY + + + 959C created for batch version of PEAKFQ, 1/04 960C Paul Hummel of AQUA TERRA Consultants 961C 962C + + + DUMMY ARGUMENTS + + + 963 INTEGER IBEGYR, IENDYR, ISKUOP, IKROPT 964 REAL GENSKU, HISTPD, QHIOUT, QLWOUT, GAGEB, RMSEGS, 965 $ FLAT, FLONG, XSYSPK, XHSTPK 966 CHARACTER*(*) STAID 967C 968C + + + ARGUMENT DEFINITIONS + + + 969C STAID - Station ID being processed 970C GENSKU - generalized skew 971C HISTPD - length of historic period 972C QHIOUT - hi-outlier threshold 973C QLWOUT - lo-outlier threshold 974C GAGEB - gage base discharge 975C RMSEGS - standard error of generalized skew 976C IBEGYR - beginning year of analysis 977C IENDYR - ending year of analysis 978C ISKUOP - skew computation option, 979C -1 - Station 980C 0 - Weighted 981C 1 - Generalized 982C IKROPT - allow urban/regularized peaks (0 - no, 1 -yes) 983C FLAT - station latitude, decimal 984C FLONG - station longitude, decimal 985C XSYSPK - highest systematic peak 986C XHSTPK - lowest historic peak 987C 988C + + + LOCAL VARIABLES + + + 989 INTEGER I,J 990C 991C + + + FUNCTIONS + + + 992 INTEGER ZLNTXT 993C 994C + + + EXTERNALS + + + 995 EXTERNAL ZLNTXT Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 30 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 996C 997C + + + END SPECIFICATIONS + + + 998C 999 write(99,*) 'Updating spec file Station info' 1000C start with station ID, remove any duplicate identifier at end 1001 J = 0 1002 I = ZLNTXT(STAID) - 1 1003 DO WHILE (I.GT.0) 1004 IF (STAID(I:I).EQ."-") THEN 1005 J = I 1006 I = 0 1007 ELSE 1008 I = I - 1 1009 END IF 1010 END DO 1011 IF (J.GT.0) THEN 1012 STAID = STAID(1:J-1) 1013 END IF 1014 WRITE(92,*) 'Station ',STAID 1015C skew parameters 1016 IF (ISKUOP.EQ.-1) THEN 1017 WRITE(92,*) ' SkewOpt Station' 1018 ELSE IF (ISKUOP.EQ.0) THEN 1019 WRITE(92,*) ' SkewOpt Weighted' 1020 ELSE IF (ISKUOP.EQ.1) THEN 1021 WRITE(92,*) ' SkewOpt Generalized' 1022 END IF 1023 WRITE(92,*) ' GenSkew ',GENSKU 1024 WRITE(92,*) ' SkewSE ',RMSEGS 1025C historic parameters 1026 WRITE(92,*) ' BegYear ',IBEGYR 1027 WRITE(92,*) ' EndYear ',IENDYR 1028 WRITE(92,*) ' HistPeriod ',HISTPD 1029C other flow parameters 1030 IF (IKROPT.EQ.1) THEN 1031 WRITE(92,*) ' Urb/Reg Yes' 1032 ELSE 1033 WRITE(92,*) ' Urb/Reg No' 1034 END IF 1035 WRITE(92,*) ' LoThresh ',QLWOUT 1036 WRITE(92,*) ' HiThresh ',QHIOUT 1037 WRITE(92,*) ' GageBase ',GAGEB 1038 WRITE(92,*) ' Latitude ',FLAT 1039 WRITE(92,*) ' Longitude ',FLONG 1040 WRITE(92,*) ' HiSys ',XSYSPK 1041 WRITE(92,*) ' LoHist ',XHSTPK 1042C 1043 RETURN 1044 END Bytes of stack required for this program unit: 96. Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 31 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- FLAT (REAL) scalar 950s 965s 1038o FLONG (REAL) scalar 950s 965s 1039o GAGEB (REAL) scalar 949s 964s 1037o GENSKU (REAL) scalar 948s 964s 1023o HISTPD (REAL) scalar 948s 964s 1028o I (INTEGER) scalar 989s 1002= 1003u 1004u 1004u 1005u 1006= 1008u 1008= IBEGYR (INTEGER) scalar 949s 963s 1026o IENDYR (INTEGER) scalar 949s 963s 1027o IKROPT (INTEGER) scalar 950s 963s 1030u ISKUOP (INTEGER) scalar 950s 963s 1016u 1018u 1020u J (INTEGER) scalar 989s 1001= 1005= 1011u 1012u QHIOUT (REAL) scalar 948s 964s 1036o QLWOUT (REAL) scalar 948s 964s 1035o RMSEGS (REAL) scalar 949s 964s 1024o STAID (CHARACTER) scalar 948s 966s 1002r 1002r 1002r 1004u 1012= 1012u 1014o 1014o 1004i WRITESPECSTA SUBROUTINE 947s XHSTPK (REAL) scalar 950s 965s 1041o XSYSPK (REAL) scalar 950s 965s 1040o ZLNTXT FUNCTION 992s 995u 1002u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 32 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE UPDATESPECFILE Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1045C 1046C 1047C 1048 SUBROUTINE UPDATESPECFILE 1049 I (FUNIT,SPCFIL) 1050C 1051C + + + PURPOSE + + + 1052C Replace existing spec file with updated verbose version. 1053C 1054C + + + DUMMY ARGUMENTS + + + 1055 INTEGER FUNIT 1056 CHARACTER*80 SPCFIL 1057C 1058C + + + ARGUMENT DEFINITIONS + + + 1059C FUNIT - Fortran unit number of original spec file 1060C SPCFIL - name of original spec file 1061C 1062C + + + LOCAL VARIABLES + + + 1063 CHARACTER*80 ISTR 1064C 1065C + + + INPUT FORMATS + + + 1066 1000 FORMAT(A) 1067C 1068C + + + END SPECIFICATIONS + + + 1069C 1070C delete original spec file 1071 CLOSE(FUNIT,STATUS='DELETE') 1072 OPEN(FUNIT,FILE=SPCFIL) 1073 REWIND 92 !back to start of temporary verbose spec file 1074 DO !echo temporary file to updated spec file 1075 READ(92,1000,END=120) ISTR 1076 WRITE(FUNIT,1000) TRIM(ISTR) 1077 END DO 1078C 1079 120 CONTINUE !get here on end of file 1080 1081 CLOSE(92,STATUS='DELETE') 1082 CLOSE(FUNIT) 1083C 1084 RETURN 1085 END Bytes of stack required for this program unit: 64. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- FUNIT (INTEGER) scalar 1049s 1055s 1071i 1072i 1076o 1082i ISTR (CHARACTER) scalar 1063s 1075i 1075i 1076r SPCFIL (CHARACTER) scalar 1049s 1056s 1072i UPDATESPECFILE SUBROUTINE 1048s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 33 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 120 1075g 1079s 1000 1066s 1075f 1076f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 34 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE JFLUSH Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1086C 1087C 1088C 1089 SUBROUTINE JFLUSH 1090 I ( INP, OUT ) 1091C 1092C + + + PURPOSE + + + 1093C Copy warning and error messages from temporary file to the 1094C output file. Close and delete temporary file. 1095C 1096C + + + DUMMY ARGUMENTS + + + 1097 INTEGER INP, OUT 1098C 1099C + + + LOCAL VARIABLES + + + 1100 INTEGER AGAIN 1101 CHARACTER*80 RECORD 1102C 1103C + + + INPUT FORMATS + + + 1104 1000 FORMAT ( A ) 1105C 1106C + + + OUTPUT FORMATS + + + 1107 2000 FORMAT ( A ) 1108C 1109C + + + END SPECIFICATIONS + + + 1110C 1111C end and rewind temporary file 1112 ENDFILE ( UNIT = INP) 1113 REWIND ( UNIT = INP) 1114C 1115C copy records from INPut file to OUTput file 1116 AGAIN = 1 1117 100 CONTINUE 1118 READ (INP,1000,END=108,ERR=109) RECORD 1119C no problem 1120 WRITE (OUT,2000) RECORD 1121 GO TO 110 1122 108 CONTINUE 1123C end of file, delete temporary file 1124 CLOSE ( UNIT = INP, STATUS = 'DELETE' ) 1125 AGAIN = 0 1126 GO TO 110 1127 109 CONTINUE 1128C error reading, assume end of temporary file, delete 1129 CLOSE ( UNIT = INP, STATUS = 'DELETE' ) 1130 AGAIN = 0 1131 GO TO 110 1132 110 CONTINUE 1133 IF (AGAIN .EQ. 1) GO TO 100 1134C 1135 RETURN 1136 END Bytes of stack required for this program unit: 80. Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 35 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- AGAIN (INTEGER) scalar 1100s 1116= 1125= 1130= 1133u INP (INTEGER) scalar 1090s 1097s 1112i 1113i 1118i 1124i 1129i JFLUSH SUBROUTINE 1089s OUT (INTEGER) scalar 1090s 1097s 1120o RECORD (CHARACTER) scalar 1101s 1118i 1118i 1120o 1120o -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 100 1117s 1133g 110 1121g 1126g 1131g 1132s 108 1118g 1122s 109 1118g 1127s 1000 1104s 1118f 2000 1107s 1120f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 36 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE COMSKU Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1137C 1138C 1139C 1140 SUBROUTINE COMSKU 1141 I (WDMSFL, DSN, 1142 O GENSKU, RETCOD) 1143C 1144C + + + PURPOSE + + + 1145C This routine computes generalized skew from WRC guidelines using 1146C the routine WCFGSM with latitude and longitude from the 1147C attributes of the dataset. 1148C 1149C + + + DUMMY ARGUMENTS + + + 1150 INTEGER WDMSFL, DSN, RETCOD 1151 REAL GENSKU 1152C 1153C + + + ARGUMENT DEFINITIONS + + + 1154C WDMSFL - Fortran unit number for users WDM file 1155C DSN - dataset number in WDM file to use for lat-long 1156C GENSKU - skew coefficient 1157C RETCOD - return code, 0 - successful computation 1158C non-zero for unsuccessful computation 1159C 1160C + + + LOCAL VARIABLES + + + 1161 REAL RLAT, RLONG 1162C 1163C + + + FUNCTIONS + + + 1164 REAL WCFGSM 1165C 1166C + + + EXTERNALS + + + 1167 EXTERNAL WCFGSM, WDBSGL 1168C 1169C + + + END SPECIFICATIONS + + + 1170C 1171C get latitude and longitude 1172 CALL WDBSGL ( WDMSFL, DSN, RLAT, RLONG, RETCOD ) 1173 IF (RETCOD .EQ. 0) THEN 1174C compute skew 1175 GENSKU = WCFGSM ( RLAT, RLONG ) 1176 ELSE 1177C default to 0.0 1178 GENSKU = 0.0 1179 END IF 1180C 1181 RETURN 1182 END -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 37 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- COMSKU SUBROUTINE 1140s DSN (INTEGER) scalar 1141s 1150s 1172r 1172r 1172r GENSKU (REAL) scalar 1142s 1151s 1175= 1178= RETCOD (INTEGER) scalar 1142s 1150s 1172r 1172r 1172r 1173u RLAT (REAL) scalar 1161s 1172r 1172r 1172r 1175r 1175r 1175r RLONG (REAL) scalar 1161s 1172r 1172r 1172r 1175r 1175r 1175r WCFGSM FUNCTION 1164s 1167u 1175u WDBSGL SUBROUTINE 1167u 1172u WDMSFL (INTEGER) scalar 1141s 1150s 1172r 1172r 1172r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 38 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. FUNCTION STRRETREM Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1183C 1184C 1185C 1186 CHARACTER*80 FUNCTION STRRETREM 1187 M (S) 1188C 1189C + + + PURPOSE + + + 1190C Returns leading portion of incoming string up to first delimeter 1191C and returns incoming string without that portion. 1192C Example: StrRetRem("This string") = "This", and s is reduced to "string" 1193C Example: StrRetRem("This,string") = "This", and s is reduced to "string" 1194C 1195C + + + HISTORY + + + 1196C created for batch version of PEAKFQ, 9/03 1197C Paul Hummel of AQUA TERRA Consultants 1198C 1199C + + + DUMMY ARGUMENTS + + + 1200 CHARACTER*80 S 1201C 1202C + + + ARGUMENT DEFINITIONS + + + 1203C S - string to be analyzed 1204C 1205C + + + LOCAL VARIABLES + + + 1206 INTEGER I, J 1207 CHARACTER S1(80) 1208 CHARACTER*80 OUTSTR 1209C 1210C + + + FUNCTIONS + + + 1211 INTEGER STRFND 1212C 1213C + + + INTRINSICS + + + 1214 INTRINSIC LEN 1215C 1216C + + + EXTERNALS + + + 1217 EXTERNAL STRFND, ZLJUST, CVARAR 1218C 1219C + + + END SPECIFICATIONS + + + 1220C 1221 CALL ZLJUST(S) 1222 CALL CVARAR(80,S,80,S1) 1223 I = STRFND(80,S1,1,'"') 1224 IF (I .EQ. 1) THEN !string beginning 1225 S = S(2:80) 1226 CALL CVARAR(80,S,80,S1) 1227 I = STRFND(80,S1,1,'"') !string end 1228 ELSE 1229 I = STRFND(80,S,1,' ') !blank delimeter 1230 J = STRFND(80,S,1,',') !comma delimeter 1231 IF (J .GT. 0) THEN !comma found 1232 IF (I .EQ. 0 .OR. J .LT. I) THEN 1233 I = J 1234 END IF Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 39 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1235 END IF 1236 END IF 1237 1238 IF (I .GT. 0) THEN !found delimeter 1239 OUTSTR = S(1:I-1) !string to return 1240 S = S(I+1:80) !string remaining 1241 CALL ZLJUST(S) 1242 IF (S(1:1) .EQ. ',' .And. I .NE. J) THEN 1243 S = S(2:80) 1244 END IF 1245 ELSE !take it all 1246 OUTSTR = S 1247 S = '' !nothing left 1248 END IF 1249 1250 STRRETREM = OUTSTR 1251 1252Cprh WRITE (*,*) "STRRETREM:'" // TRIM(OUTSTR) // 1253Cprh $ "','" // TRIM(S) // "'" 1254 1255 RETURN 1256 END Bytes of stack required for this program unit: 56. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- CVARAR SUBROUTINE 1217u 1222u 1226u I (INTEGER) scalar 1206s 1223= 1224u 1227= 1229= 1232u 1232u 1233= 1238u 1239u 1240u 1242u J (INTEGER) scalar 1206s 1230= 1231u 1232u 1233u 1242u OUTSTR (CHARACTER) scalar 1208s 1239= 1246= 1250u S (CHARACTER) scalar 1187s 1200s 1221r 1221r 1221r 1222r 1222r 1222r 1225= 1225u 1226r 1226r 1226r 1229r 1229r 1229r 1230r 1230r 1230r 1239u 1240= 1240u 1241r 1241r 1241r 1242u 1243= 1243u 1246u 1247= 1242i S1 (CHARACTER) array 1207s 1222r 1222r 1222r 1223r 1223r 1223r 1226r 1226r 1226r 1227r 1227r 1227r STRFND FUNCTION 1211s 1217u 1223u 1227u 1229u 1230u STRRETREM (CHARACTER) scalar 1186s 1250= STRRETREM FUNCTION 1186s ZLJUST SUBROUTINE 1217u 1221u 1241u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 40 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. FUNCTION IYESNO Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1257C 1258C 1259C 1260 INTEGER FUNCTION IYESNO 1261 I (ISTR,IDEF) 1262C 1263C + + + PURPOSE + + + 1264C Return an integer value of 0 for NO or 1 for YES 1265C based on the contents of a batch input record. 1266C If NO or YES not found, use IDEF as default. 1267C 1268C + + + DUMMY ARGUMENTS + + + 1269 INTEGER IDEF 1270 CHARACTER*(*) ISTR 1271C 1272C + + + ARGUMENT DEFINITIONS + + + 1273C ISTR - input string from batch fiel 1274C IDEF - default value if NO or YES not found on record 1275C 1276C + + + LOCAL VARIABLES + + + 1277 INTEGER IVAL 1278C 1279C + + + FUNCTIONS + + + 1280 INTEGER ZLNTXT 1281C 1282C + + + EXTERNALS + + + 1283 EXTERNAL ZLNTXT 1284C 1285C + + + END SPECIFICATIONS + + + 1286C 1287 IF (ZLNTXT(ISTR).GT.0) THEN !look for YES or NO specification 1288 IF (ISTR.EQ.'NO') THEN 1289 IVAL = 0 1290 ELSE IF (ISTR.EQ.'YES') THEN 1291 IVAL = 1 1292 END IF 1293 ELSE !assume default 1294 IVAL = IDEF 1295 END IF 1296C 1297 IYESNO = IVAL 1298C 1299 RETURN 1300 END -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- IDEF (INTEGER) scalar 1261s 1269s 1294u ISTR (CHARACTER) scalar 1261s 1270s 1287r 1287r 1287r 1288u 1290u 1288i Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 41 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1290i IVAL (INTEGER) scalar 1277s 1289= 1291= 1294= 1297u IYESNO FUNCTION 1260s IYESNO (INTEGER) scalar 1260s 1297= ZLNTXT FUNCTION 1280s 1283u 1287u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 42 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE UPCASE Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1301C 1302C 1303C 1304 SUBROUTINE UPCASE 1305 M (STRING) 1306C 1307C + + + PURPOSE + + + 1308C Convert a character string from lower case to upper case 1309C 1310C + + + DUMMY ARGUMENTS + + + 1311 CHARACTER*(*) STRING 1312C 1313C + + + ARGUMENT DEFINITIONS + + + 1314C STRING - character string to be made upper case 1315C 1316C + + + LOCAL VARIABLES + + + 1317 INTEGER I,ICH,ILEN 1318C 1319C + + + INTRINSICS + + + 1320 INTRINSIC ICHAR, MOD, CHAR 1321C 1322C + + + END SPECIFICATIONS + + + 1323C 1324 ILEN = LEN(STRING) 1325 DO 10 I = 1, ILEN 1326 ICH= ICHAR(STRING(I:I)) 1327 ICH= MOD(ICH,128) 1328 IF (ICH.GE.97 .AND. ICH.LE.122) THEN 1329C character is lower case 1330 STRING(I:I)= CHAR(ICH-32) 1331 END IF 1332 10 CONTINUE 1333C 1334 RETURN 1335 END Bytes of stack required for this program unit: 32. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- I (INTEGER) scalar 1317s 1326u 1326u 1330u 1330u ICH (INTEGER) scalar 1317s 1326= 1327r 1327= 1328u 1328u 1330u ILEN (INTEGER) scalar 1317s 1324= 1325u STRING (CHARACTER) scalar 1305s 1311s 1324r 1326r 1330= UPCASE SUBROUTINE 1304s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 43 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 1325d 1332s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 44 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. FUNCTION CVRDEC Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1336C 1337C 1338C 1339 REAL FUNCTION CVRDEC 1340 I (ISTR) 1341C 1342C + + + PURPOSE + + + 1343C Convert a character variable to a real number. 1344C Returns 0.0 if string is blank. 1345C 1346C + + + DUMMY ARGUMENTS + + + 1347 CHARACTER*(*) ISTR 1348C 1349C + + + ARGUMENT DEFINITIONS + + + 1350C ISTR - string to convert 1351C 1352C + + + LOCAL VARIABLES + + + 1353 INTEGER ILEN 1354 REAL RVAL 1355 CHARACTER*1 ISTR1(80) 1356C 1357C + + + FUNCTIONS + + + 1358 INTEGER ZLNTXT 1359 REAL CHRDEC 1360C 1361C + + + EXTERNALS + + + 1362 EXTERNAL ZLNTXT, CHRDEC, CVARAR 1363C 1364C + + + END SPECIFICATIONS + + + 1365C 1366 ILEN = ZLNTXT(ISTR) 1367 IF (ILEN.GT.0) THEN 1368 CALL CVARAR (ILEN,ISTR,ILEN,ISTR1) 1369 RVAL = CHRDEC(ILEN,ISTR1) 1370 ELSE 1371 RVAL = 0.0 1372 END IF 1373C 1374 CVRDEC = RVAL 1375C 1376 RETURN 1377 END Bytes of stack required for this program unit: 8. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- CHRDEC FUNCTION 1359s 1362u 1369u CVARAR SUBROUTINE 1362u 1368u CVRDEC FUNCTION 1339s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 45 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- CVRDEC (REAL) scalar 1339s 1374= ILEN (INTEGER) scalar 1353s 1366= 1367u 1368r 1368r 1368r 1368r 1368r 1368r 1369r 1369r 1369r ISTR (CHARACTER) scalar 1340s 1347s 1366r 1366r 1366r 1368r 1368r 1368r ISTR1 (CHARACTER) array 1355s 1368r 1368r 1368r 1369r 1369r 1369r RVAL (REAL) scalar 1354s 1369= 1371= 1374u ZLNTXT FUNCTION 1358s 1362u 1366u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 46 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. FUNCTION CVRINT Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1378C 1379C 1380C 1381 INTEGER FUNCTION CVRINT 1382 I (ISTR) 1383C 1384C + + + PURPOSE + + + 1385C Convert a character variable to an integer number. 1386C Returns 0 if string is blank. 1387C 1388C + + + DUMMY ARGUMENTS + + + 1389 CHARACTER*(*) ISTR 1390C 1391C + + + ARGUMENT DEFINITIONS + + + 1392C ISTR - string to convert 1393C 1394C + + + LOCAL VARIABLES + + + 1395 INTEGER ILEN, IVAL 1396 CHARACTER*1 ISTR1(80) 1397C 1398C + + + FUNCTIONS + + + 1399 INTEGER ZLNTXT, CHRINT 1400C 1401C + + + EXTERNALS + + + 1402 EXTERNAL ZLNTXT, CHRINT, CVARAR 1403C 1404C + + + END SPECIFICATIONS + + + 1405C 1406 ILEN = ZLNTXT(ISTR) 1407 IF (ILEN.GT.0) THEN 1408 CALL CVARAR (ILEN,ISTR,ILEN,ISTR1) 1409 IVAL = CHRINT(ILEN,ISTR1) 1410 ELSE 1411 IVAL = 0 1412 END IF 1413C 1414 CVRINT = IVAL 1415C 1416 RETURN 1417 END -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- CHRINT FUNCTION 1399s 1402u 1409u CVARAR SUBROUTINE 1402u 1408u CVRINT FUNCTION 1381s CVRINT (INTEGER) scalar 1381s 1414= ILEN (INTEGER) scalar 1395s 1406= 1407u 1408r 1408r 1408r 1408r 1408r 1408r 1409r 1409r 1409r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:15 2004 Page: 47 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- ISTR (CHARACTER) scalar 1382s 1389s 1406r 1406r 1406r 1408r 1408r 1408r ISTR1 (CHARACTER) array 1396s 1408r 1408r 1408r 1409r 1409r 1409r IVAL (INTEGER) scalar 1395s 1409= 1411= 1414u ZLNTXT FUNCTION 1399s 1402u 1406u