Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 1 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE J407XE 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 SUBROUTINE J407XE 5 # ( IA1, IA3, PAUSE, EMAOPT, UPDATEFG ) 6 C 7 C + + + PURPOSE + + + 8 C This routine processes users input and options and controls 9 C processing for frequency analysis and output. 10 C J407 -- USGS-WRC FLOOD FREQUENCY ANALYSIS PER WRC BULL 17-B, 1981. 11 C 12 C FOR CURRENT VERSION/REV-DATE, SEE SUBRTNE PRTPHD, FMT NO. 201/202. 13 C ALSO SEE SUBRTNE WCFAGB, FMT NO 1. 14 C 15 C + + + HISTORY + + + 16 C VER 76.00 BY WKIRBY, WRD-NR, MAY 1976. (BULL.17) 17 C VER 2.0 BY WKIRBY, WRD-NR, APRIL 77. (BULL.17-A) 18 C VER 3.0 BY WKIRBY, WRD-NR, MAY 1979. 19 C VER 3.7P - PRIME REVISIONS - K.FLYNN 12/83. 20 C VER 3.8P - WK 12/86, 7/88. 21 C SET ARGUMENTS = 0 FOR NON-ANNIE/NON-WDM USE 22 C VER 3.9P - WK, AML 12/88 23 C VER 3.9A-P - WK, AML 2/89 24 C MODIFIED 8/9/89 AML (deleted BLOCKDATA) 25 C Modified 6/93 AML to coding convention and add requirements 26 C for distribution by Texas, changed to an 27 C 80 char/record print file, made Z,H,N,Y 28 C input records optional 29 C Updated for batch version of PEAKFQ, 9/03 30 C Paul Hummel of AQUA TERRA Consultants 31 C 32 C + + + DUMMY ARGUMENTS + + + 33 INTEGER IA1, IA3, PAUSE, EMAOPT 34 LOGICAL UPDATEFG 35 C 36 C + + + ARGUMENT DEFINITIONS + + + 37 C IA1 - Fortran unit number for message file 38 C IA3 - Fortran unit number for users WDM file 39 C PAUSE - Indicator flag for pause between stations 40 C 1 - yes, pause and wait for user response 41 C 2 - no, display summary of results and continue 42 C EMAOPT - indicator flag for performing EMA analysis 43 C 0 - no, just do traditional J407 44 C 1 - yes, run EMA 45 C UPDATEFG - boolean to indicate type of run 46 C TRUE - run is just updating the spec file (don't do graphics) 47 C FALSE - full run 48 C 49 C + + + PARAMETERS + + + 50 INCLUDE 'pmxint.inc' 51 INCLUDE 'pmxpk.inc' 52 C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 53 C + + + COMMON BLOCKS + + + 54 INCLUDE 'cjobop.inc' 55 INCLUDE 'clunit.inc' 56 INCLUDE 'cstaid.inc' 57 C 58 COMMON/ HEADNS / HEADNG(9) 59 CHARACTER*80 HEADNG 60 C 61 INCLUDE 'cj407.inc' 62 INCLUDE 'cwcf0.inc' 63 INCLUDE 'cwcf1.inc' 64 INCLUDE 'cwcf2.inc' 65 C 66 C 67 C + + + LOCAL VARIABLES + + + 68 INTEGER IPKPTR(MXPK), IQUAL(MXPK) 69 REAL FCXPG(MXINT) 70 INTEGER MAXPKS, IER, NFCXPG, JSEQNO,NPROC, NERR, NSKIP, NSTAYR, 71 & NSKIP1, NPKS, I, NPKPLT, 72 $ ISTART, HSTFLG, XPKS 73 Cprh $ , SCLU, CNUM, CLEN, SGRP, MXLN, SCI, IWRT 74 C 75 C + + + EQUIVALENCES + + + 76 EQUIVALENCE (IQUAL(1),IPKPTR(1)) 77 C 78 C + + + SAVES + + + 79 SAVE JSEQNO, NFCXPG, FCXPG 80 C 81 C + + + FUNCTIONS + + + 82 REAL GAUSEX 83 C 84 C + + + INTRINSICS + + + 85 INTRINSIC INT, MIN0, MAX0 86 C 87 C + + + EXTERNALS + + + 88 EXTERNAL INPUT, PRTPHD, PRTINP, ALIGNP, PRTFIT 89 EXTERNAL OUTPUT, PLTFRQ, RUNEMA, WCFAGB 90 EXTERNAL SORTM, PRTIN2, PRTIN3, GAUSEX 91 C 92 C + + + DATA INITIALIZATIONS + + + 93 DATA IER, NFCXPG , JSEQNO 94 $ / 0, -777 , 0 / 95 C 96 C + + + FORMATS + + + 97 1000 FORMAT(///' End PEAKFQ analysis.' 98 $ /' Stations processed :',I8 99 $ /' Number of errors :',I8 100 $ /' Stations skipped :',I8 101 $ /' Station years :',I8//) 102 C 103 C + + + END SPECIFICATIONS + + + 104 C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 105 C SUBROUTINES USED -- 106 C INPUT - READS INPUT DATA INTO J407. USES INPUT2, PKFRD4. 107 C ALSO - INPUT1/ANNIE, INPUT3/PKFQH3. 108 C J407VR - BLOCK DATA, VERSION NUMBER 109 C PRTPHD - PRINTS PAGE-HEADINGS 110 C PRTINP - PRINTS INPUT DATA LISTINGS 111 C ALIGNP - ALIGNS PROB-PLOT POSITIONS WITH DISCHARGES FOR PRINTING 112 C PRTFIT - PRINTS TABLE OF FITTED DISTRIBUTION 113 C OUTPUT - OUTPUTS RESULTS TO FILE. USES OUTPT1/ANNIE AND -- 114 C BCFPCH - PUNCHED OUTPUT IN USGS BASIN-CHAR FILE FMT. DUMMY IN PRIME. 115 C PLTFRQ - FREQUENCY CURVE PLOT. USES FRQPLT, FRQPL...X. 116 C FRQPLT - FREQUENCY CURVE PRINTER-PLOT. USES J407P4, J407SC. 117 C WCFAGB - DOES THE WRC FLOOD FREQUENCY CALCULATIONS. USES ALL 118 C WCF... ROUTINES (WCFAPI ... WCFFCX) AND COMMONS 119 C WCFCM0,1,2. ALSO USES GAUSEX,STUTX,OUTKGB,HARTXX.... 120 C WCFBDI - BLOCK DATA FOR WCFAGB. 121 C 122 C------------------------ 123 C 124 C maximum number of peaks 125 MAXPKS = MXPK 126 C 127 WRITE(*,*) "J407XE:IA1:",IA1," INFORM:",INFORM," MSG1:",MSG1 128 C CHECK FOR REPEAT CALL FROM MAIN PGM 129 IF( JSEQNO .LE. 0 .OR. INFORM .GT. 0) THEN 130 C 131 MSG = MSG1 132 C 133 C PRINT J407 PAGE HEADER AT START OF JOB 134 CALL PRTPHD( 0 , IWXMOD, EMAOPT, IA3 ) 135 C 136 MSL = 2 137 IF(IDEBUG.EQ.1) MSL = 4 138 NOPPOS = 1 - (IPLTOP+IPPOS) 139 WSKLAT=0. 140 IF(ISKUDP.EQ.1)WSKLAT=0.10 141 IF(ISKUDP.EQ.2)WSKLAT=0.01 142 NOEPFC = NOXPA 143 NOCLIM = NOCLM 144 C 145 NPROC = 0 146 NERR = 0 147 NSKIP = 0 148 NSTAYR = 0 149 JSEQNO = 0 150 END IF 151 C 152 C for ascii input need to reset start flag for 1st record read 153 ISTART = 0 154 C 155 100 CONTINUE 156 JSEQNO = JSEQNO + 1 Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 157 CALL PRTPHD( 1000 , JSEQNO, EMAOPT, IA3) 158 C 159 CALL INPUT (IA1,IA3,INFORM,MAXPKS,EMAOPT,IA3, 160 M ISTART, 161 O STAID,PKS,IPKSEQ,XQUAL,IQUAL, 162 O NHIST,NSYS,HISTPD,QHIOUT,QLWOUT,GAGEB, 163 O GENSKU,RMSEGS, IGSOPT, NSKIP1, IER ) 164 C 165 write(*,*)'After INPUT, NSYS,NHIST',NSYS,NHIST 166 NPKS=NHIST+NSYS 167 NSTAYR=NSTAYR+NPKS 168 NSKIP=NSKIP+NSKIP1 169 C count peaks to be skipped 170 XPKS = 0 171 DO 120 I = 1, NPKS 172 IF (PKS(I) .LT. 0.0) XPKS = XPKS + 1 173 120 CONTINUE 174 IF(IER.GE.2) GO TO 970 175 IF(NSKIP1.NE.0 ) THEN 176 JSEQNO = JSEQNO + 1 177 CALL PRTPHD( 1000, JSEQNO, EMAOPT, IA3 ) 178 ENDIF 179 C 180 IGSOPT=MAX0(-1,MIN0(+1,IGSOPT)) 181 IF(IWXMOD.NE.0 .AND. RMSEGS.LE.0.) RMSEGS = RMSDGS 182 STAID(79:90) = ' ' 183 IF(NHIST.GT.0 .OR. HISTPD.GT.0.) STAID(79:90) = 184 $ '* HISTORIC *' 185 C 186 C CALL PRTPHD( 2001 , -999 ) 187 CALL PRTINP( IDEBUG, XPKS, EMAOPT, IA3 ) 188 C 189 write(99,*)'Debug Info for ',STAID 190 CALL WCFAGB(PKS, PKLOG, WRCPP, SYSPP, NPKS, IER) 191 192 IF (EMAOPT.EQ.1) THEN 193 write(*,*)'calling RUNEMA: NPKS,NSYS,GENSKU,RMSEGS', 194 $ NPKS,NSYS,GENSKU,RMSEGS 195 CALL RUNEMA(NPKS,PKS) 196 END IF 197 198 IF(IER .GE. 3) THEN 199 NERR=NERR+1 200 IF(MSL .LT. 4) CALL PRTIN2 ( 1 ,MSG, NPKS, IPKSEQ,PKS,XQUAL, 201 $ EMAOPT, IA3 ) 202 ELSE 203 NPROC=NPROC+1 204 C 205 C PRINT FITTED LOG-PEARSON TYPE III FREQUENCY CURVES PARAMETERS 206 C AND ORDINATES 207 CALL PRTFIT ( IDEBUG, EMAOPT, IA3 ) 208 C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 209 Ckmf moved call to output to after plot so that the plot will 210 Ckmf be drawn before the output is displayed. When pause 211 Ckmf was added, it caused the plot to display after the 212 Ckmf summary statistics were cleared from the screen, making 213 Ckmf it appear as if the plot went with the next station 214 Ckmf IF(IBCPUN.EQ.1) CALL OUTPUT(STAID,SYSUAV,SYSUSD,SYSSKW, 215 Ckmf $ WRCUAV,WRCUSD,WRCSKW,WRCFC , INT(HISTPN+.5), NSYS, 216 Ckmf $ IBCPUN, IPUNCH, IA1,IA3, PAUSE ) 217 C 218 IF(IPLTOP.NE.0 .OR. (IPPOS*IPRTOP.NE.0)) THEN 219 C 220 C sort input peak logs and correlate with plotting positions 221 CALL SORTM( PKLOG, IPKPTR, 1, -1, NPKS ) 222 IF(NHIST.GT.0) CALL ALIGNP(IPKPTR,IPKSEQ,NPKS,NHIST,SYSPP) 223 C 224 C print input data and plotting positions 225 IF(IPRTOP .NE. 0 ) THEN 226 IF(IPPOS.EQ.0) THEN 227 C short output 228 CALL PRTIN2(0,MSG,NPKS,IPKSEQ,PKS,XQUAL,EMAOPT,IA3) 229 ELSE 230 C longer output 231 CALL PRTIN3 (MSG,NPKS,IPKSEQ,PKS,XQUAL, 232 $ GAGEB, IPKPTR, SYSPP, WRCPP, WEIBA, 233 $ EMAOPT, IA3) 234 END IF 235 END IF 236 C 237 IF(IPLTOP.NE.0) THEN 238 C initialize (if necessary) 239 IF(NFCXPG.LE.0) THEN 240 Cprh DO 170 I = 1,31 241 DO 170 I = 1,MXINT 242 FCXPG(I) = GAUSEX(TXPROB(I)) 243 170 CONTINUE 244 NFCXPG = INDX2 - INDX1 + 1 245 ENDIF 246 NPKPLT=NHIST+NSYS-NBGB 247 C convert to std deviates 248 DO 190 I=1,NPKPLT 249 SYSPP(I)=GAUSEX(SYSPP(I)) 250 WRCPP(I)=GAUSEX(WRCPP(I)) 251 190 CONTINUE 252 C set flag to plot historic adjusted peaks, 0-y,1-n 253 C Note: When qhiout > .01 and histpd <= .05, 254 C the historic adjusted peaks are plotted, 255 C however, they will equal the systematic 256 C peaks becaus they have not actually been 257 C adjusted. They are plotted like this as 258 C a warning to the user, Is it appropriate 259 C to have a high-outlier discharge threshold 260 C when you don't have a lenght of historical Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 261 C period? 262 IF (QHIOUT .LE. 0.01 .AND. HISTPD .LE. 0.5) THEN 263 C don't plot historic adjusted peaks 264 HSTFLG = 1 265 ELSE 266 C do plot historic adjusted peaks 267 HSTFLG = 0 268 END IF 269 IF (.NOT.UPDATEFG) THEN 270 CALL PLTFRQ( MSG, HEADNG, IPLTOP, GRFMT, 271 $ NPKPLT, PKLOG, SYSPP, WRCPP, WEIBA, 272 $ SYSRFC(INDX1),WRCFC(INDX1),FCXPG(INDX1),NFCXPG, 273 $ IWXMOD,HSTFLG, 274 $ NOCLIM, CLIML(INDX1), CLIMU(INDX1), JSEQNO ) 275 END IF 276 ENDIF 277 END IF 278 Ckmf relocated output so in sync with graphics 279 IF(IBCPUN.GT.0) THEN 280 C output statistics to wdm (1 or 3) and/or watstore 2 or 3) 281 C summary screen output if pause=1 282 CALL OUTPUT (STAID,SYSUAV,SYSUSD,SYSSKW, 283 $ WRCUAV,WRCUSD,WRCSKW,WRCFC , 284 $ INT(HISTPN+.5), NSYS, 285 $ IBCPUN, IPUNCH, IA1,IA3, PAUSE ) 286 ELSE IF (INFORM .EQ. 1 .AND. PAUSE .EQ. 1) THEN 287 C no output statistics, but summary screen for wdm input 288 Cprh CALL OUTPT2 ( STAID, WRCUAV, WRCUSD, WRCSKW, WRCFC, IA1 ) 289 END IF 290 END IF 291 C 292 IF (INFORM .EQ. 2 .AND. PAUSE .EQ. 1) THEN 293 C ascii input and pause between statTions, stats to screen 294 Cprh CALL OUTPT2 ( STAID, WRCUAV, WRCUSD, WRCSKW, WRCFC, 295 Cprh I IA1 ) 296 END IF 297 Ckf IF (INFORM .EQ. 2 .AND. IMODFG .EQ. 1) THEN 298 C tell user completed, if ascii file 299 Ckf SCLU = 121 300 Ckf SGRP = 69 301 Ckf MXLN = 10 302 Ckf SCI = 1 303 Ckf IWRT = 0 304 Ckf CNUM = 1 305 Ckf CLEN = 76 306 Ckf CALL PMXTXA (IA1,SCLU,SGRP,MXLN,SCI,IWRT,CNUM,CLEN, 307 Ckf $ HEADNG(9)(1:76)) 308 Ckf END IF 309 C 310 Cprh IF (IER .EQ. 3) THEN 311 CprhC tell user aborted 312 Cprh SCLU = 121 Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 313 Cprh SGRP = 75 314 Cprh MXLN = 10 315 Cprh SCI = 1 316 Cprh IWRT = 0 317 Cprh CNUM = 1 318 Cprh CLEN = 76 319 Cprh CALL PMXTXA (IA1,SCLU,SGRP,MXLN,SCI,IWRT,CNUM,CLEN, 320 Cprh $ HEADNG(9)(1:76)) 321 Cprh END IF 322 C 323 IF(INFORM .LE. 0) RETURN 324 GO TO 100 325 C 326 970 CONTINUE 327 WRITE(MSG,1000) NPROC,NERR,NSKIP,NSTAYR 328 C 329 RETURN 330 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) ------------------------------------------------------------------------------------------------------------------------------- ALIGNP SUBROUTINE 88u 222u ALLSOM (INTEGER) scalar 44 (I1)4s (I1)7s BIGLOG (REAL) scalar 316 (I2)4s (I2)12s CLIML (REAL) array 256 (I3)2s (I3)4s 274r 270r 270r CLIMU (REAL) array 384 (I3)3s (I3)5s 274r 270r 270r CLSIZE (REAL) scalar 40 (I2)3s (I2)11s CPAMP1 (REAL) scalar 344 (I2)6s (I2)14s CPAMP2 (REAL) scalar 348 (I2)6s (I2)14s CPAMP3 (REAL) scalar 352 (I2)6s (I2)14s DOSTA (CHARACTER) array 48 (I1)4s (I1)9s EMAOPT (INTEGER) scalar 5s 33s 134r 134r 134r 157r 157r 157r 159r 159r 159r 177r 177r 177r 187r 187r 187r 192u 201r 200r 200r 207r 207r 207r 228r 228r 228r 233r 231r 231r EPFC (REAL) array 128 (I3)2s (I3)4s EPS1 (REAL) scalar 320 (I2)5s (I2)13s EPS2 (REAL) scalar 324 (I2)5s (I2)13s FCXPG (REAL) array 69s 79s 242= 272r 270r 270r GAGEB (REAL) scalar 12 (I4)2s (I4)10s 162r 159r 159r 232r 231r 231r GAUSEX FUNCTION 82s 90u 242u 249u 250u GENSKU (REAL) scalar 0 (I4)2s (I4)10s 163r 159r 159r 194o GRFMT (CHARACTER) scalar 348 (I1)4s (I1)8s 270r 270r 270r GSKWGT (REAL) scalar 108 (I4)6s (I4)10s GSMAX (REAL) scalar 32 (I2)3s (I2)11s GSMIN (REAL) scalar 28 (I2)3s (I2)11s HEADNG (CHARACTER) array 0 58s 59s 270r 270r 270r HISTPD (REAL) scalar 28 (I4)3s (I4)10s 162r 159r 159r 183u 262u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- HISTPN (REAL) scalar 100 (I4)6s (I4)10s 284u HISTWT (REAL) scalar 104 (I4)6s (I4)10s HRECWO (REAL) scalar 328 (I2)5s (I2)13s HRECWS (REAL) scalar 336 (I2)5s (I2)13s HRECWX (REAL) scalar 332 (I2)5s (I2)13s HSTFLG (INTEGER) scalar 72s 264= 267= 273r 270r 270r I (INTEGER) scalar 71s 172u 242u 242u 249u 249u 250u 250u IA1 (INTEGER) scalar 5s 33s 127o 159r 159r 159r 285r 282r 282r IA3 (INTEGER) scalar 5s 33s 134r 134r 134r 157r 157r 157r 159r 159r 159r 159r 159r 159r 177r 177r 177r 187r 187r 187r 201r 200r 200r 207r 207r 207r 228r 228r 228r 233r 231r 231r 285r 282r 282r IBCPUN (INTEGER) scalar 4 (I1)2s (I1)5s 279u 285r 282r 282r IDEBUG (INTEGER) scalar 12 (I1)2s (I1)5s 137u 187r 187r 187r 207r 207r 207r IER (INTEGER) scalar 70s 93/ 163r 159r 159r 174u 190r 190r 190r 198u IGSOPT (INTEGER) scalar 4 (I4)2s (I4)9s 163r 159r 159r 180r 180r 180= IMODFG (INTEGER) scalar 40 (I1)4s (I1)7s INCRD (INTEGER) scalar 4 (I5)2s (I5)3s INDX1 (INTEGER) scalar 44 (I2)4s (I2)9s 244u 272u 272u 272u 274u 274u INDX2 (INTEGER) scalar 48 (I2)4s (I2)9s 244u INDXPT (INTEGER) array 56 (I2)4s (I2)9s INFIL2 (INTEGER) scalar 12 (I5)2s (I5)3s INFORM (INTEGER) scalar 16 (I5)2s (I5)3s 127o 129u 159r 159r 159r 286u 292u 323u INPUT SUBROUTINE 88u 159u IPKPTR (INTEGER) array 0 68s 76u 221r 221r 221r 222r 222r 222r 232r 231r 231r IPKSEQ (INTEGER) array 1600 (I6)2s (I6)6s 161r 159r 159r 200r 200r 200r 222r 222r 222r 228r 228r 228r 231r 231r 231r IPLTOP (INTEGER) scalar 0 (I1)2s (I1)5s 138u 218u 237u 270r 270r 270r IPPOS (INTEGER) scalar 16 (I1)2s (I1)5s 138u 218u 226u IPRTOP (INTEGER) scalar 8 (I1)2s (I1)5s 218u 225u IPUNCH (INTEGER) scalar 8 (I5)2s (I5)3s 285r 282r 282r IQUAL (INTEGER) array 0 68s 76u 161r 159r 159r ISKUDP (INTEGER) scalar 20 (I1)3s (I1)6s 140u 141u ISTART (INTEGER) scalar 72s 153= 160r 159r 159r IWXMOD (INTEGER) scalar 372 (I2)7s (I2)10s 134r 134r 134r 181u 273r 270r 270r J407XE SUBROUTINE 4s JOBTTL (CHARACTER) scalar 0 (I1)11s (I1)12s JSEQNO (INTEGER) scalar 70s 79s 93/ 129u 149= 156u 156= 157r 157r 157r 176u 176= 177r 177r 177r 274r 270r 270r MAXPKS (INTEGER) scalar 70s 125= 159r 159r 159r MOROPT (INTEGER) array 32 (I1)3s (I1)6s MSG (INTEGER) scalar 0 (I2)2s (I2)8s 131= 200r 200r 200r 228r 228r 228r 231r 231r 231r 270r 270r 270r 327o MSG1 (INTEGER) scalar 0 (I5)2s (I5)3s 127o 131u MSL (INTEGER) scalar 4 (I2)2s (I2)8s 136= 137= 200u MXINT (INTEGER) scalar (I7)1s (I7)2s (I2)9u (I2)12u (I4)12u (I3)4u (I3)4u (I3)4u (I3)5u (I3)5u 69u 241u MXPK (INTEGER) scalar (I8)1s (I8)2s (I6)2u (I6)2u (I6)2u (I6)3u (I6)3u (I6)8u 68u 68u 125u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- NBGB (INTEGER) scalar 84 (I4)5s (I4)9s 246u NERR (INTEGER) scalar 70s 146= 199u 199= 327o NFCXPG (INTEGER) scalar 70s 79s 93/ 239u 244= 272r 270r 270r NHIOUT (INTEGER) scalar 92 (I4)5s (I4)9s NHIST (INTEGER) scalar 24 (I4)2s (I4)9s 162r 159r 159r 165o 166u 183u 222u 222r 222r 222r 246u NHISTN (INTEGER) scalar 96 (I4)5s (I4)9s NINDX (INTEGER) scalar 52 (I2)4s (I2)9s NLWOUT (INTEGER) scalar 88 (I4)5s (I4)9s NMISS (INTEGER) scalar 76 (I4)5s (I4)9s NOCLIM (INTEGER) scalar 24 (I2)2s (I2)8s 143= 274r 270r 270r NOCLM (INTEGER) scalar 28 (I1)3s (I1)6s 143u NOEPFC (INTEGER) scalar 20 (I2)2s (I2)8s 142= NOPPOS (INTEGER) scalar 8 (I2)2s (I2)8s 138= NOSYS (INTEGER) scalar 16 (I2)2s (I2)8s NOTRAN (INTEGER) scalar 12 (I2)2s (I2)8s NOXPA (INTEGER) scalar 24 (I1)3s (I1)6s 142u NPKPLT (INTEGER) scalar 71s 246= 248u 271r 270r 270r NPKS (INTEGER) scalar 71s 166= 167u 171u 190r 190r 190r 194o 195r 195r 195r 200r 200r 200r 221r 221r 221r 222r 222r 222r 228r 228r 228r 231r 231r 231r NPROC (INTEGER) scalar 70s 145= 203u 203= 327o NSKIP (INTEGER) scalar 70s 147= 168u 168= 327o NSKIP1 (INTEGER) scalar 71s 163r 159r 159r 168u 175u NSTAYR (INTEGER) scalar 70s 148= 167u 167= 327o NSYS (INTEGER) scalar 80 (I4)5s (I4)9s 162r 159r 159r 165o 166u 194o 246u 284r 282r 282r OUTPUT SUBROUTINE 89u 282u PAUSE (INTEGER) scalar 5s 33s 285r 282r 282r 286u 292u PKLOG (REAL) array 800 (I6)2s (I6)4s 190r 190r 190r 221r 221r 221r 271r 270r 270r PKS (REAL) array 0 (I6)2s (I6)4s 161r 159r 159r 172u 190r 190r 190r 195r 195r 195r 200r 200r 200r 228r 228r 228r 231r 231r 231r PLTFRQ SUBROUTINE 89u 270u PRTFIT SUBROUTINE 88u 207u PRTIN2 SUBROUTINE 90u 200u 228u PRTIN3 SUBROUTINE 90u 231u PRTINP SUBROUTINE 88u 187u PRTPHD SUBROUTINE 88u 134u 157u 177u QHIOUT (REAL) scalar 20 (I4)2s (I4)11s 162r 159r 159r 262u QLWOUT (REAL) scalar 16 (I4)2s (I4)11s 162r 159r 159r RMSDGS (REAL) scalar 340 (I2)6s (I2)14s 181u RMSEGS (REAL) scalar 8 (I4)2s (I4)10s 163r 159r 159r 181u 181= 194o RUNEMA SUBROUTINE 89u 195u SIGHOT (REAL) scalar 360 (I2)7s (I2)15s SIGLOT (REAL) scalar 356 (I2)7s (I2)15s SORTM SUBROUTINE 90u 221u SPCFUN (INTEGER) scalar 20 (I5)2s (I5)3s STAID (CHARACTER) scalar 0 (I9)2s (I9)3s 161r 159r 159r 182= 183= 189o 189o 282r 282r 282r SUMH (REAL(kind 8)) array 176 (I4)8s (I4)15s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- SUMS (REAL(kind 8)) array 152 (I4)8s (I4)15s SYSAAV (REAL) scalar 132 (I4)7s (I4)11s SYSASD (REAL) scalar 136 (I4)7s (I4)11s SYSASK (REAL) scalar 140 (I4)7s (I4)11s SYSBAS (REAL) scalar 112 (I4)6s (I4)11s SYSMAX (REAL) scalar 148 (I4)8s (I4)11s SYSMIN (REAL) scalar 144 (I4)8s (I4)12s SYSPAB (REAL) scalar 116 (I4)6s (I4)12s SYSPP (REAL) array 2400 (I6)3s (I6)5s 190r 190r 190r 222r 222r 222r 232r 231r 231r 249r 249r 249r 249= 271r 270r 270r SYSRFC (REAL) array 512 (I3)3s (I3)5s 272r 270r 270r SYSSKW (REAL) scalar 128 (I4)7s (I4)12s 282r 282r 282r SYSUAV (REAL) scalar 120 (I4)6s (I4)12s 282r 282r 282r SYSUSD (REAL) scalar 124 (I4)7s (I4)12s 282r 282r 282r TXPROB (REAL) array 184 (I2)4s (I2)12s 242r 242r 242r UPDATEFG (LOGICAL) scalar 5s 34s 269u WCFAGB SUBROUTINE 89u 190u WCXAUX (REAL) array 364 (I2)7s (I2)15s WEIBA (REAL) scalar 36 (I2)3s (I2)11s 232r 231r 231r 271r 270r 270r WORK (REAL) array 200 (I4)8s (I4)12s WRCAAV (REAL) scalar 52 (I4)4s (I4)13s WRCASD (REAL) scalar 56 (I4)4s (I4)13s WRCASK (REAL) scalar 60 (I4)4s (I4)13s WRCBAS (REAL) scalar 32 (I4)3s (I4)13s WRCFC (REAL) array 0 (I3)2s (I3)4s 272r 270r 270r 283r 282r 282r WRCHHB (REAL) scalar 64 (I4)4s (I4)13s WRCHOT (REAL) scalar 68 (I4)4s (I4)13s WRCLOW (REAL) scalar 72 (I4)5s (I4)13s WRCPAB (REAL) scalar 36 (I4)3s (I4)14s WRCPP (REAL) array 3200 (I6)3s (I6)5s 190r 190r 190r 232r 231r 231r 250r 250r 250r 250= 271r 270r 270r WRCSKW (REAL) scalar 48 (I4)4s (I4)14s 283r 282r 282r WRCUAV (REAL) scalar 40 (I4)3s (I4)14s 283r 282r 282r WRCUSD (REAL) scalar 44 (I4)4s (I4)14s 283r 282r 282r WSKLAT (REAL) scalar 312 (I2)4s (I2)12s 139= 140= 141= XPKS (INTEGER) scalar 72s 170= 172u 172= 187r 187r 187r XQUAL (CHARACTER) array 0 (I6)8s (I6)9s 161r 159r 159r 200r 200r 200r 228r 228r 228r 231r 231r 231r -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 100 155s 324g 120 171d 173s 170 241d 243s 970 174g 326s 190 248d 251s 1000 97s 327f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 11 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PRTPHD Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 331 C 332 C 333 C 334 SUBROUTINE PRTPHD 335 # ( II , IARG2, EMAOPT, WDMSFL ) 336 C 337 C + + + PURPOSE + + + 338 C PRINTS PAGE HEADINGS FOR J407 / BULLETIN 17. 339 C 340 C + + + HISTORY + + + 341 C Updated 9/03 for batch version of PEAKFQ, 342 C Most common blocks now found in include files, 343 C Replaced MSG with MSG1 as declared in include file clunit.inc, 344 C Removed reference to JBOPT (equivalenced to IPLTOP) - not used 345 C Paul Hummel, AQUA TERRA Consultants 346 C 347 C + + + DUMMY ARGUMENTS + + + 348 INTEGER II, IARG2, EMAOPT, WDMSFL 349 C 350 C + + + ARGUMENT DEFINITIONS + + + 351 C II - <= 0 - print initial header 352 C 1000 - print page header 353 C 2001 - print station id / header 354 C 3000 - print header for list of peaks 355 C IARG2 - sequence number of station in input 356 C EMAOPT - indicator flag for performing EMA analysis 357 C 0 - no, just do traditional J407 358 C 1 - yes, run EMA 359 C WDMSFL - FORTRAN unit number for input WDM file 360 C 361 C + + + COMMON BLOCKS + + + 362 COMMON / HEADNS / HEAD1, HEAD2, HEAD3, HEAD4, HEAD5, 363 $ HEAD6, HEAD7, HEAD8, HEAD9 364 CHARACTER*80 HEAD1, HEAD2, HEAD3, HEAD4, HEAD5, 365 $ HEAD6, HEAD7, HEAD8, HEAD9 366 CHARACTER*80 HEADNG(9), HEAD14(6) 367 EQUIVALENCE (HEADNG(1), HEAD14(1), HEAD1) 368 C 369 INCLUDE 'cstaid.inc' 370 INCLUDE 'cjobop.inc' 371 Cprh don't see anywhere JBOPT is used 372 Cprh INTEGER JBOPT(8) 373 Cprh EQUIVALENCE (JBOPT(1),IPLTOP) 374 C 375 INCLUDE 'clunit.inc' 376 C 377 C + + + LOCAL VARIABLES + + + 378 CHARACTER*1 BLANK 379 C INTEGER JDATE(3) 380 INTEGER I, L70,L15,L48,L80,LOC,L10 381 C INTEGER JTIME, ERRCOD, OLEN 382 CHARACTER*3 CPRTOP(2), CDEBUG(2) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 383 CHARACTER*18 CPLTOP(4) 384 CHARACTER*14 CBCPUN(4) 385 CHARACTER*5 CIPPOS(2) 386 CHARACTER*20 CNFORM(3) 387 CHARACTER*80 FNAME 388 CHARACTER*1 HEADA9(80), CSTA(10) 389 CHARACTER*16 CHDTTM 390 C 391 C + + + SAVES + + + 392 SAVE DISCLM, DT,STAIND,PAGIND 393 CHARACTER*80 DISCLM(2) 394 INTEGER DT(6),STAIND,PAGIND 395 C 396 C + + + FUNCTIONS + + + 397 INTEGER LENSTR, CKNBLV 398 C 399 C + + + EXTERNALS + + + 400 C EXTERNAL DATTIM, ZIPC 401 EXTERNAL SYDATM, DATLST, LENSTR, CARVAR, CVARAR, CHRCHR, CKNBLV 402 C 403 C + + + DATA INITIALIZATIONS + + + 404 DATA BLANK / ' ' /, L15,L48,L70,L80,L10/15,48,70,80,10/ 405 DATA CPLTOP/'None','Graphics device','Line printer', 406 $ 'Graphics & Printer'/ 407 DATA CBCPUN/'None','WDM','WATSTORE','Both'/ 408 DATA CPRTOP/'No','Yes'/ 409 DATA CDEBUG/'No','Yes'/ 410 DATA CIPPOS/'Short','Long'/ 411 DATA CNFORM/'WDM file ','WATSTORE peak file', 412 $ 'Log-Pearson records'/ 413 DATA CSTA /'S','t','a','t','i','o','n',' ','-',' '/ 414 DATA STAIND,PAGIND/0,0/ 415 C 416 C + + + FORMATS + + + 417 C 101 FORMAT(///' EXECUTION BEGINNING AT DATE, TIME =',I5,2(1H/,I2),I7 418 C & //) 419 C 100 FORMAT( 28X,21A1) 420 101 FORMAT(/,23X,' --- PROCESSING DATE/TIME ---', 421 $ //,28X,21A1) 422 102 FORMAT(/,24X,' --- PROCESSING OPTIONS --- ', 423 $ //,19X,' Plot option = ',A 424 $ /,19X,' Basin char output = ',A 425 $ /,19X,' Print option = ',A 426 $ /,19X,' Debug print = ',A 427 $ /,19X,' Input peaks listing = ',A 428 $ /,19X,' Input peaks format = ',A,/) 429 C $ ' IPLTOP IBCPUN IPRTOP IDEBUG IPPOS ISKUDP NOXPA', 430 C $ ' NOCLM INFORM '/ 9I8//) 431 C 103 FORMAT( /' Input format =',I4,' ANNIE/WDM FILE RETRIEVAL', 432 C $ 2A1,T21,66X,T21, ' WATSTORE PEAK-FILE CARDS ', 433 C $ 1A1,T21,66X,T21, ' LOG-PEARSON CARDS ' ) 434 110 FORMAT(19X,' Input files used:') Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 435 111 FORMAT(19X,' peaks (WDM) - ',A) 436 112 FORMAT(19X,' peaks (ascii) - ',A) 437 113 FORMAT(19X,' specifications - ',A) 438 114 FORMAT(19X,' Output file(s): ',/ 439 $ 19X,' main - ',A) 440 115 FORMAT(19X,' bcd - ',A) 441 199 FORMAT( '1' ) 442 200 FORMAT(' ') 443 201 FORMAT( 2X,'Program PeakFq',11X,'U. S. GEOLOGICAL SURVEY', 444 $ 13X,'Seq.',I3.3,'.',I3.3 ) 445 Cprh 202 FORMAT( 21X, 'OFFICE OF SURFACE WATER, RESTON, VA' ) 446 202 FORMAT( 2X,'Ver. 5.0 Beta 6', 447 $ 5X,'Annual peak flow frequency analysis', 448 $ 6X,'Run Date / Time' ) 449 Cprh 203 FORMAT( 21X, 'ANNUAL PEAK FLOW FREQUENCY ANALYSIS' ) 450 203 FORMAT( 2X,'11/11/2004', 451 $ 10X,'following Bulletin 17-B Guidelines',7X,A) 452 213 FORMAT( 2X,'11/11/2004', 453 $ 9X,'using Expected Moments Algorithm (EMA)',4X,A ) 454 Cprh 204 FORMAT( 21X, 'Following Bulletin 17-B Guidelines' ) 455 Cprh 205 FORMAT( 21X, ' Program peakfq ' ) 456 205 FORMAT(12X,'WARNING: For experimental use only, EMA is not the') 457 206 FORMAT(22X,'standard method for flood frequency analysis.') 458 Cprh 206 FORMAT( 21X, ' (Version 4.1, February, 2002)' ) 459 207 FORMAT( 20X, A40 ) 460 227 FORMAT(A16) 461 208 FORMAT( ' ',2A1,T1,5(' *** EXPERIMENTAL *** ') ) 462 C 209 FORMAT(2X, A10, A15, 2X, A48) 463 301 FORMAT( 2X, '********* NOTICE -- Preliminary machine ', 464 $ 'computations. *********' ) 465 302 FORMAT( 2X, '********* User responsible for assessment ', 466 $ 'and interpretation. *********' ) 467 401 FORMAT( 2X, '********* WARNING -- Experimental ', 468 $ 'modification of 17B calculations *********' ) 469 402 FORMAT( 2X, '*************** User is responsible for ', 470 $ 'assessment and interpretation. *********' ) 471 501 FORMAT( '1', /, (A) ) 472 502 FORMAT( 80A1 ) 473 503 FORMAT(///, A, /, A, / ) 474 504 FORMAT( /, A, /, A, / ) 475 476 600 FORMAT( A,'Bulletin 17B analysis run ',21A1) 477 601 FORMAT( A,'EMA analsis run ',21A1) 478 700 FORMAT(I2.2,'/',I2.2,'/',I4,I3.2,':',I2.2) 479 C 480 C + + + END SPECIFICATIONS + + + 481 C 482 IF( II .LE. 0 ) THEN 483 C PRINT INITIAL PAGE, DETERMINE DATE AND TIME. 484 C CALL DATTIM( JDATE, JTIME ) 485 C WRITE(MSG1, 101)JDATE,JTIME 486 CALL SYDATM (DT(1),DT(2),DT(3),DT(4),DT(5),DT(6)) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 14 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 ------------------------------------------------------------- 487 Ckmf check for y2k, convert 2-digit year to 4 digit year if needed. 488 IF (DT(1) .LT. 90) THEN 489 C assume 2000 or later 490 DT(1) = DT(1) + 2000 491 Cprh fixed bug in following record that had D(I), not D(1) 492 ELSE IF (DT(1) .LT. 100) THEN 493 C assume before 2000 494 DT(1) = DT(1) + 1900 495 END IF 496 WRITE(CHDTTM,700) DT(2),DT(3),DT(1),DT(4),DT(5) 497 WRITE(MSG1, 199) 498 WRITE(MSG1, 201) STAIND,PAGIND 499 WRITE(MSG1, 202) 500 IF (EMAOPT .EQ. 0) THEN 501 C traditional B17 analysis 502 WRITE(MSG1, 203) CHDTTM 503 ELSE 504 C using new EMA option 505 WRITE(MSG1, 213) CHDTTM 506 WRITE(MSG1, 205) 507 WRITE(MSG1, 206) 508 END IF 509 Cprh WRITE(MSG1, 205) 510 Cprh WRITE(MSG1, 206) 511 Cprh original version never set JOBTTL, leave out for new version 512 Cprh WRITE(MSG1, 207) JOBTTL 513 Cprh CALL DATLST (DT,CHDTTM,OLEN,ERRCOD) 514 515 Cprh WRITE(MSG1, 101) (CHDTTM(I),I=1,OLEN) 516 WRITE(MSG1, 102) CPLTOP(IPLTOP+1), CBCPUN(IBCPUN+1), 517 $ CPRTOP(IPRTOP+1), CDEBUG(IDEBUG+1), 518 $ CIPPOS(IPPOS+1), CNFORM(INFORM) 519 C WRITE(MSG1, 103) INFORM, (' ',I=1,INFORM) 520 WRITE(MSG1, 110) 521 IF (INFORM.EQ.1) THEN 522 C WDM file 523 INQUIRE(WDMSFL,NAME=FNAME) 524 WRITE(MSG1,111) FNAME 525 ELSE 526 C Ascii file 527 INQUIRE(INCRD,NAME=FNAME) 528 WRITE(MSG1, 112) FNAME 529 END IF 530 INQUIRE(SPCFUN,NAME=FNAME) 531 WRITE(MSG1,113) FNAME 532 INQUIRE(MSG1,NAME=FNAME) 533 WRITE(MSG1,114) FNAME 534 IF (IBCPUN.GE.2) THEN 535 C outputting additional BCD file 536 INQUIRE(IPUNCH,NAME=FNAME) 537 WRITE(MSG1,115) FNAME 538 END IF Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 539 WRITE(MSG1,200) 540 C prepare page heading in character strings 541 WRITE(HEAD1,200) 542 WRITE(HEAD2,201) STAIND,PAGIND 543 WRITE(HEAD3,202) 544 IF (EMAOPT .EQ. 0) THEN 545 C traditional B17 analysis 546 WRITE(HEAD4,203) CHDTTM 547 HEAD5 = ' ' 548 HEAD6 = ' ' 549 ELSE 550 C using new EMA option 551 WRITE(HEAD4,213) CHDTTM 552 C include warning about using EMA method 553 WRITE(HEAD5,205) 554 WRITE(HEAD6,206) 555 END IF 556 C WRITE(HEAD7,207) JOBTTL 557 C put date/time here for plots 558 Cprh date/time now in page header 559 Cprh WRITE(HEAD7,227) CHDTTM 560 HEAD7 = ' ' 561 WRITE(HEAD8,208) (BLANK, I=1,IARG2) 562 C SET UP DISCLAIMER 563 IF(IARG2 .GE. 2) THEN 564 WRITE(DISCLM(1),401) 565 WRITE(DISCLM(2),402) 566 ELSE 567 WRITE(DISCLM(1),301) 568 WRITE(DISCLM(2),302) 569 ENDIF 570 C 571 ELSE IF( II .EQ. 1000 ) THEN 572 C PRINT PAGE HEADINGS FOR PGM OUTPUT.... 573 C FIRST INSERT SEQUENCE NUMBER 574 C WRITE(HEADNG(6)(47:50), '(I4)' ) IARG2 575 C above sequence number deleted because didn't fit in header 576 577 C start of new station 578 STAIND = STAIND + 1 579 PAGIND = 0 580 WRITE(MSG1,199) 581 Cprh header will be written under II=2001 conditional below 582 Cprh WRITE(MSG1,501) HEAD14 583 C 584 ELSE IF ( II .EQ. 2001 ) THEN 585 C start of new page 586 PAGIND = PAGIND + 1 587 WRITE(MSG1, 201) STAIND,PAGIND 588 WRITE(MSG1, 202) 589 IF (EMAOPT .EQ. 0) THEN 590 C traditional B17 analysis Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 591 WRITE(MSG1, 203) CHDTTM 592 ELSE 593 C using new EMA option 594 WRITE(MSG1, 213) CHDTTM 595 WRITE(MSG1, 205) 596 WRITE(MSG1, 206) 597 END IF 598 WRITE(MSG1,200) 599 C build station id/ description 600 CALL CHRCHR(L10,CSTA,HEADA9(1)) 601 CALL ZIPC (L70,BLANK,HEADA9(11)) 602 CALL CVARAR (L15,STAID(1:15),L15,HEADA9(11)) 603 LOC = LENSTR(L80,HEADA9) 604 CALL CVARAR (L48,STAID(21:68),L48,HEADA9(LOC+3)) 605 LOC = LENSTR(L80,HEADA9) 606 CALL CARVAR (L80,HEADA9,L80,HEAD9) 607 C change null to blank 608 DO 55 I = 11,80 609 IF (ICHAR(HEADA9(I)) .EQ. 0) HEADA9(I) = ' ' 610 55 CONTINUE 611 CALL CTRSTR (L80,HEADA9) 612 WRITE(MSG1, 502) HEADA9 613 Cprh WRITE(MSG, 100) (CHDTTM(I),I=1,OLEN) 614 C WRITE(HEAD9,209)'Station - ',STAID(1:15), STAID(21:68) 615 C WRITE(MSG1,'(/1X,(A))') HEAD9 616 Cprh update station/page index on HEAD2 for future use 617 WRITE(HEAD2,201) STAIND,PAGIND+1 618 ELSE IF ( II .EQ. 2002 ) THEN 619 WRITE(MSG1,503) DISCLM 620 ELSE IF ( II .EQ. 3000 ) THEN 621 C PRINT HEADING FOR LIST OF INPUT PEAKS 622 WRITE(MSG1,501) HEADNG 623 IF(IARG2 .NE. -3301) WRITE(MSG1,504) DISCLM 624 ELSE 625 STOP 777 626 END IF 627 C 628 RETURN 629 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) ------------------------------------------------------------------------------------------------------------------------------- ALLSOM (INTEGER) scalar 44 (I1)4s (I1)7s BLANK (CHARACTER) scalar 378s 404/ 561o 561o 601r 601r 601r CARVAR SUBROUTINE 401u 606u CBCPUN (CHARACTER) array 384s 407/ 516o 516o CDEBUG (CHARACTER) array 382s 409/ 517o 517o CHDTTM (CHARACTER) scalar 389s 496o 496o 502o 502o 505o 505o 546o 546o Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 551o 551o 591o 591o 594o 594o CHRCHR SUBROUTINE 401u 600u CIPPOS (CHARACTER) array 385s 410/ 518o 518o CKNBLV FUNCTION 397s 401u CNFORM (CHARACTER) array 386s 411/ 518o 518o CPLTOP (CHARACTER) array 383s 405/ 516o 516o CPRTOP (CHARACTER) array 382s 408/ 517o 517o CSTA (CHARACTER) array 388s 413/ 600r 600r 600r CTRSTR SUBROUTINE 611u CVARAR SUBROUTINE 401u 602u 604u DATLST Procedure 401u DISCLM (CHARACTER) array 392s 393s 564o 564o 565o 565o 567o 567o 568o 568o 619o 619o 623o 623o DOSTA (CHARACTER) array 48 (I1)4s (I1)9s DT (INTEGER) array 392s 394s 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 486r 488u 490u 490= 492u 494u 494= 496o 496o 496o 496o 496o EMAOPT (INTEGER) scalar 335s 348s 500u 544u 589u FNAME (CHARACTER) scalar 387s 523i 524o 524o 527i 528o 528o 530i 531o 531o 532i 533o 533o 536i 537o 537o GRFMT (CHARACTER) scalar 348 (I1)4s (I1)8s HEAD1 (CHARACTER) scalar 0 362s 364s 367u 541o 541o HEAD14 (CHARACTER) array 0 366s 367u HEAD2 (CHARACTER) scalar 80 362s 364s 542o 542o 617o 617o HEAD3 (CHARACTER) scalar 160 362s 364s 543o 543o HEAD4 (CHARACTER) scalar 240 362s 364s 546o 546o 551o 551o HEAD5 (CHARACTER) scalar 320 362s 364s 547= 553o 553o HEAD6 (CHARACTER) scalar 400 363s 365s 548= 554o 554o HEAD7 (CHARACTER) scalar 480 363s 365s 560= HEAD8 (CHARACTER) scalar 560 363s 365s 561o 561o HEAD9 (CHARACTER) scalar 640 363s 365s 606r 606r 606r HEADA9 (CHARACTER) array 388s 600r 600r 600r 601r 602r 602r 602r 603r 603r 603r 604r 604r 604r 605r 605r 605r 606r 606r 606r 609r 609= 611r 612o 612o 601r 601r 611r 611r HEADNG (CHARACTER) array 0 366s 367u 622o 622o I (INTEGER) scalar 380s 561= 561u 609u 609u IARG2 (INTEGER) scalar 335s 348s 561o 563u 623u IBCPUN (INTEGER) scalar 4 (I1)2s (I1)5s 516u 534u IDEBUG (INTEGER) scalar 12 (I1)2s (I1)5s 517u II (INTEGER) scalar 335s 348s 482u 571u 584u 618u 620u IMODFG (INTEGER) scalar 40 (I1)4s (I1)7s INCRD (INTEGER) scalar 4 (I5)2s (I5)3s 527i INFIL2 (INTEGER) scalar 12 (I5)2s (I5)3s INFORM (INTEGER) scalar 16 (I5)2s (I5)3s 518u 521u IPLTOP (INTEGER) scalar 0 (I1)2s (I1)5s 516u IPPOS (INTEGER) scalar 16 (I1)2s (I1)5s 518u IPRTOP (INTEGER) scalar 8 (I1)2s (I1)5s 517u IPUNCH (INTEGER) scalar 8 (I5)2s (I5)3s 536i ISKUDP (INTEGER) scalar 20 (I1)3s (I1)6s JOBTTL (CHARACTER) scalar 0 (I1)11s (I1)12s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- L10 (INTEGER) scalar 380s 404/ 600r 600r 600r L15 (INTEGER) scalar 380s 404/ 602r 602r 602r 602r 602r 602r L48 (INTEGER) scalar 380s 404/ 604r 604r 604r 604r 604r 604r L70 (INTEGER) scalar 380s 404/ 601r 601r 601r L80 (INTEGER) scalar 380s 404/ 603r 603r 603r 605r 605r 605r 606r 606r 606r 606r 606r 606r 611r 611r 611r LENSTR FUNCTION 397s 401u 603u 605u LOC (INTEGER) scalar 380s 603= 604u 605= MOROPT (INTEGER) array 32 (I1)3s (I1)6s MSG1 (INTEGER) scalar 0 (I5)2s (I5)3s 497o 498o 499o 502o 505o 506o 507o 516o 520o 524o 528o 531o 532i 533o 537o 539o 580o 587o 588o 591o 594o 595o 596o 598o 612o 619o 622o 623o NOCLM (INTEGER) scalar 28 (I1)3s (I1)6s NOXPA (INTEGER) scalar 24 (I1)3s (I1)6s PAGIND (INTEGER) scalar 392s 394s 414/ 498o 542o 579= 586u 586= 587o 617u PRTPHD SUBROUTINE 334s SPCFUN (INTEGER) scalar 20 (I5)2s (I5)3s 530i STAID (CHARACTER) scalar 0 (I9)2s (I9)3s 602r 602r 602r 604r 604r 604r STAIND (INTEGER) scalar 392s 394s 414/ 498o 542o 578u 578= 587o 617o SYDATM SUBROUTINE 401u 486u WDMSFL (INTEGER) scalar 335s 348s 523i ZIPC SUBROUTINE 601u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 55 608d 610s 200 442s 539f 541f 598f 600 476s 700 478s 496f 110 434s 520f 101 420s 201 443s 498f 542f 587f 617f 301 463s 567f 401 467s 564f 501 471s 622f 601 477s 111 435s 524f 102 422s 516f 202 446s 499f 543f 588f 302 465s 568f 402 469s 565f 502 472s 612f 112 436s 528f 203 450s 502f 546f 591f 503 473s 619f 113 437s 531f 213 452s 505f 551f 594f 504 474s 623f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 19 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 ------------------------------------------------------------- 114 438s 533f 205 456s 506f 553f 595f 115 440s 537f 206 457s 507f 554f 596f 207 459s 227 460s 208 461s 561f 199 441s 497f 580f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 20 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PRTINP Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 630 C 631 C 632 C 633 SUBROUTINE PRTINP 634 # (IDEBUG ,XPKS, EMAOPT, WDMSFL) 635 C 636 C + + + PURPOSE + + + 637 C PRINTS LISTINGS OF J407/WCF INPUT DATA -- INPUT PARAMS. 638 C 639 C + + + DUMMY ARGUMENTS + + + 640 INTEGER IDEBUG, XPKS, EMAOPT, WDMSFL 641 C 642 C + + + ARGUMENT DEFINITIONS + + + 643 C IDEBUG - 644 C XPKS - number of peaks to be excluded from analysis (neg value) 645 C EMAOPT - indicator flag for performing EMA analysis 646 C 0 - no, just do traditional J407 647 C 1 - yes, run EMA 648 C WDMSFL - FORTRAN unit number for input WDM file 649 C 650 C + + + PARAMETERS + + + 651 INCLUDE 'pmxint.inc' 652 C 653 C + + + COMMON BLOCKS + + + 654 INCLUDE 'cwcf0.inc' 655 INCLUDE 'cwcf1.inc' 656 C 657 C + + + LOCAL VARIABLES + + + 658 CHARACTER * 15 DWORK(3) 659 CHARACTER*12 SKUOP(3) 660 INTEGER I 661 CHARACTER*8 YNHIST 662 C 663 C + + + INTRINSICS + + + 664 INTRINSIC INT 665 C 666 C + + + EXTERNALS + + + 667 EXTERNAL PRTPHD 668 C 669 C + + + DATA INITIALIZATIONS + + + 670 DATA SKUOP /'STATION SKEW',' WEIGHTED ', 671 $ ' GENERALIZED'/ 672 C 673 C + + + FORMATS + + + 674 4 FORMAT(// 21X, 'I N P U T D A T A S U M M A R Y') 675 5 FORMAT( 676 $ /16X,'Number of peaks in record = ',I8, 677 $ /16X,'Peaks not used in analysis = ',I8, 678 $ /16X,'Systematic peaks in analysis = ',I8, 679 $ /16X,'Historic peaks in analysis = ',I8, 680 $ /16X,'Years of historic record = ',I8, 681 $ /16X,'Generalized skew = ',F8.3, Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 682 $ /16X,'Standard error of generalized skew = ',2X,A6, 683 $ /16X,'Skew option = ',A, 684 $ /16X,'Gage base discharge = ',F8.1, 685 $ /16X,'User supplied high outlier threshold = ',A, 686 $ /16X,'User supplied low outlier criterion = ',A, 687 $ /16X,'Plotting position parameter = ',F8.2) 688 6 FORMAT(/) 689 C $ /' -- YEARS OF RECORD -- HISTORIC GENERALIZED', 690 C $ 'GAGE BASE'/ 691 C $ 5X,'SYSTEMATIC HISTORIC',6X,'PEAKS',8X,'SKEW',7X, 692 C $ 'GENERAL. SKEW OPTION', 693 C $ 5X, 'DISCHARGE'/ 694 C $ /' ', 8X,I3,5X,I7,9X,I3,7X,F7.3,8X, A6,5X, A ,2X,F8.1,// 695 C $ ' USER-SET OUTLIER CRITERIA ' / 696 C $ ' HIGH OUTLIER LOW OUTLIER ' / 697 C $ 6X, 2A ) 698 C 699 C + + + END SPECIFICATIONS + + + 700 C 701 DO 107 I = 1,3 702 DWORK(I) = ' -- ' 703 107 CONTINUE 704 C 705 IF (NHIST .GT. 0 .OR. HISTPN .GT. 0.0) THEN 706 C historic adjustment applied 707 YNHIST = ' YES' | WARNING -- CHARACTER scalar (YNHIST) is set but never used. 708 ELSE 709 YNHIST = ' NO' 710 END IF 711 IF(RMSEGS .GT. 0.) WRITE(DWORK(1),'(F6.3)') RMSEGS 712 IF(QHIOUT .GT. 0.) WRITE(DWORK(2),'(1X,F9.1)') QHIOUT 713 IF(QLWOUT .GT. 0.) WRITE(DWORK(3),'(1X,F9.1)') QLWOUT 714 WRITE(MSG,6) 715 CALL PRTPHD( 2001 , -999, EMAOPT, WDMSFL ) 716 WRITE(MSG,4) 717 WRITE(MSG,5) NSYS+NHIST, XPKS, NSYS-XPKS, NHIST, 718 C $ INT(HISTPD+.5), YNHIST, GENSKU, DWORK(1), 719 $ INT(HISTPD+.5), GENSKU, DWORK(1), 720 $ SKUOP(IGSOPT+2),GAGEB, DWORK(2),DWORK(3),WEIBA 721 CALL PRTPHD( 2002, -999, EMAOPT, WDMSFL ) 722 IF(IDEBUG.NE.0) THEN 723 WRITE(MSG,*)' PEAKFQ-DEBUG OPTION SET =',IDEBUG 724 ENDIF 725 C 726 RETURN 727 END Bytes of stack required for this program unit: 72. Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- BIGLOG (REAL) scalar 316 (I2)4s (I2)12s CLSIZE (REAL) scalar 40 (I2)3s (I2)11s CPAMP1 (REAL) scalar 344 (I2)6s (I2)14s CPAMP2 (REAL) scalar 348 (I2)6s (I2)14s CPAMP3 (REAL) scalar 352 (I2)6s (I2)14s DWORK (CHARACTER) array 658s 702= 711o 711o 712o 712o 713o 713o 719o 719o 720o 720o 720o 720o EMAOPT (INTEGER) scalar 634s 640s 715r 715r 715r 721r 721r 721r EPS1 (REAL) scalar 320 (I2)5s (I2)13s EPS2 (REAL) scalar 324 (I2)5s (I2)13s GAGEB (REAL) scalar 12 (I4)2s (I4)10s 720o GENSKU (REAL) scalar 0 (I4)2s (I4)10s 719o GSKWGT (REAL) scalar 108 (I4)6s (I4)10s GSMAX (REAL) scalar 32 (I2)3s (I2)11s GSMIN (REAL) scalar 28 (I2)3s (I2)11s HISTPD (REAL) scalar 28 (I4)3s (I4)10s 719u HISTPN (REAL) scalar 100 (I4)6s (I4)10s 705u HISTWT (REAL) scalar 104 (I4)6s (I4)10s HRECWO (REAL) scalar 328 (I2)5s (I2)13s HRECWS (REAL) scalar 336 (I2)5s (I2)13s HRECWX (REAL) scalar 332 (I2)5s (I2)13s I (INTEGER) scalar 660s 702u IDEBUG (INTEGER) scalar 634s 640s 722u 723o IGSOPT (INTEGER) scalar 4 (I4)2s (I4)9s 720u INDX1 (INTEGER) scalar 44 (I2)4s (I2)9s INDX2 (INTEGER) scalar 48 (I2)4s (I2)9s INDXPT (INTEGER) array 56 (I2)4s (I2)9s IWXMOD (INTEGER) scalar 372 (I2)7s (I2)10s MSG (INTEGER) scalar 0 (I2)2s (I2)8s 714o 716o 717o 723o MSL (INTEGER) scalar 4 (I2)2s (I2)8s MXINT (INTEGER) scalar (I7)1s (I7)2s (I2)9u (I2)12u (I4)12u NBGB (INTEGER) scalar 84 (I4)5s (I4)9s NHIOUT (INTEGER) scalar 92 (I4)5s (I4)9s NHIST (INTEGER) scalar 24 (I4)2s (I4)9s 705u 717u 717o NHISTN (INTEGER) scalar 96 (I4)5s (I4)9s NINDX (INTEGER) scalar 52 (I2)4s (I2)9s NLWOUT (INTEGER) scalar 88 (I4)5s (I4)9s NMISS (INTEGER) scalar 76 (I4)5s (I4)9s NOCLIM (INTEGER) scalar 24 (I2)2s (I2)8s NOEPFC (INTEGER) scalar 20 (I2)2s (I2)8s NOPPOS (INTEGER) scalar 8 (I2)2s (I2)8s NOSYS (INTEGER) scalar 16 (I2)2s (I2)8s NOTRAN (INTEGER) scalar 12 (I2)2s (I2)8s NSYS (INTEGER) scalar 80 (I4)5s (I4)9s 717u 717u PRTINP SUBROUTINE 633s PRTPHD SUBROUTINE 667u 715u 721u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 23 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 ------------------------------------------------------------- QHIOUT (REAL) scalar 20 (I4)2s (I4)11s 712u 712o QLWOUT (REAL) scalar 16 (I4)2s (I4)11s 713u 713o RMSDGS (REAL) scalar 340 (I2)6s (I2)14s RMSEGS (REAL) scalar 8 (I4)2s (I4)10s 711u 711o SIGHOT (REAL) scalar 360 (I2)7s (I2)15s SIGLOT (REAL) scalar 356 (I2)7s (I2)15s SKUOP (CHARACTER) array 659s 670/ 720o 720o SUMH (REAL(kind 8)) array 176 (I4)8s (I4)15s SUMS (REAL(kind 8)) array 152 (I4)8s (I4)15s SYSAAV (REAL) scalar 132 (I4)7s (I4)11s SYSASD (REAL) scalar 136 (I4)7s (I4)11s SYSASK (REAL) scalar 140 (I4)7s (I4)11s SYSBAS (REAL) scalar 112 (I4)6s (I4)11s SYSMAX (REAL) scalar 148 (I4)8s (I4)11s SYSMIN (REAL) scalar 144 (I4)8s (I4)12s SYSPAB (REAL) scalar 116 (I4)6s (I4)12s SYSSKW (REAL) scalar 128 (I4)7s (I4)12s SYSUAV (REAL) scalar 120 (I4)6s (I4)12s SYSUSD (REAL) scalar 124 (I4)7s (I4)12s TXPROB (REAL) array 184 (I2)4s (I2)12s WCXAUX (REAL) array 364 (I2)7s (I2)15s WDMSFL (INTEGER) scalar 634s 640s 715r 715r 715r 721r 721r 721r WEIBA (REAL) scalar 36 (I2)3s (I2)11s 720o WORK (REAL) array 200 (I4)8s (I4)12s WRCAAV (REAL) scalar 52 (I4)4s (I4)13s WRCASD (REAL) scalar 56 (I4)4s (I4)13s WRCASK (REAL) scalar 60 (I4)4s (I4)13s WRCBAS (REAL) scalar 32 (I4)3s (I4)13s WRCHHB (REAL) scalar 64 (I4)4s (I4)13s WRCHOT (REAL) scalar 68 (I4)4s (I4)13s WRCLOW (REAL) scalar 72 (I4)5s (I4)13s WRCPAB (REAL) scalar 36 (I4)3s (I4)14s WRCSKW (REAL) scalar 48 (I4)4s (I4)14s WRCUAV (REAL) scalar 40 (I4)3s (I4)14s WRCUSD (REAL) scalar 44 (I4)4s (I4)14s WSKLAT (REAL) scalar 312 (I2)4s (I2)12s XPKS (INTEGER) scalar 634s 640s 717o 717u YNHIST (CHARACTER) scalar 661s 707= 709= -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 107 701d 703s 4 674s 716f 5 675s 717f 6 688s 714f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 24 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PRTIN2 Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 728 C 729 C 730 C 731 SUBROUTINE PRTIN2 732 # ( IOPT, MSG, NPKS, IPKSEQ, PKS, XQUAL, 733 # EMAOPT, WDMSFL ) 734 C 735 C + + + PURPOSE + + + 736 C PRINTS SHORT LIST OF INPUT PEAKS 737 C 738 C + + + DUMMY ARGUMENTS + + + 739 INTEGER MSG, NPKS, IOPT, EMAOPT, WDMSFL 740 INTEGER IPKSEQ(NPKS) 741 CHARACTER*(*) XQUAL(NPKS) 742 REAL PKS(NPKS) 743 C 744 C + + + ARGUMENT DEFINITIONS + + + 745 C IOPT - 746 C MSG - 747 C NPKS - 748 C IPKSEQ - 749 C PKS - 750 C XQUAL - 751 C EMAOPT - indicator flag for performing EMA analysis 752 C 0 - no, just do traditional J407 753 C 1 - yes, run EMA 754 C WDMSFL - FORTRAN unit number for input WDM file 755 C 756 C + + + LOCAL VARIABLES + + + 757 INTEGER I, ND2 758 C 759 C + + + EXTERNALS + + + 760 EXTERNAL PRTPHD 761 C 762 C + + + FORMATS + + + 763 14 FORMAT(///7X,25HLISTING OF INPUT PEAKS// 764 $ 9X,21H YR DISCHARGE CODE // 765 $ (5X,I8,F12.1,A6) ) 766 18 FORMAT(///' ****** AFTER CALC ABORT --') 767 104 FORMAT(//8X,'Explanation of peak discharge qualification codes', 768 $//6X,' PEAKFQ WATSTORE', 769 $ /6X,' CODE CODE DEFINITION', 770 $//6X,' D 3 Dam failure, non-recurrent flow anomaly', 771 $ /6X,' G 8 Discharge greater than stated value', 772 $ /6X,' X 3+8 Both of the above', 773 $ /6X,' L 4 Discharge less than stated value', 774 $ /6X,' K 6 OR C Known effect of regulation or ', 775 $ 'urbanization', 776 $ /6X,' H 7 Historic peak' ///) 777 1010 FORMAT('1',//) 778 1011 FORMAT(//23X,'I N P U T D A T A L I S T I N G') 779 1012 FORMAT(//,2(' WATER YEAR DISCHARGE CODES ')/) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 780 1013 FORMAT(2(I12,F15.1, 1A10)) 781 C 782 C + + + END SPECIFICATIONS + + + 783 C 784 WRITE(MSG,1010) 785 IF(IOPT .EQ. 1) WRITE(MSG,18) 786 C IF(IOPT .NE. 1) CALL PRTPHD( 3000, -3301 ) 787 C write table of observed data 788 CALL PRTPHD ( 2001, -999, EMAOPT, WDMSFL ) 789 WRITE(MSG,1011) 790 WRITE(MSG,1012) 791 ND2 = (NPKS+1)/2 792 DO 210 I = 1,ND2 793 IF (I+ND2 .LE. NPKS) THEN 794 WRITE(MSG,1013) IPKSEQ(I), PKS(I), XQUAL(I), 795 $ IPKSEQ(I+ND2), PKS(I+ND2), XQUAL(I+ND2) 796 ELSE 797 WRITE(MSG,1013) IPKSEQ(I), PKS(I), XQUAL(I) 798 END IF 799 210 CONTINUE 800 C 801 C write key to codes 802 WRITE(MSG, 104 ) 803 C 804 C WRITE(MSG,14)(IPKSEQ(I),PKS(I),XQUAL(I),I=1,NPKS) 805 C 806 RETURN 807 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) ------------------------------------------------------------------------------------------------------------------------------- EMAOPT (INTEGER) scalar 733s 739s 788r 788r 788r I (INTEGER) scalar 757s 793u 794u 794u 794u 795u 795u 795u 797u 797u 797u IOPT (INTEGER) scalar 732s 739s 785u IPKSEQ (INTEGER) array 732s 740s 794o 795o 797o MSG (INTEGER) scalar 732s 739s 784o 785o 789o 790o 794o 797o 802o ND2 (INTEGER) scalar 757s 791= 792u 793u 795u 795u 795u NPKS (INTEGER) scalar 732s 739s 740u 741u 742u 791u 793u PKS (REAL) array 732s 742s 794o 795o 797o PRTIN2 SUBROUTINE 731s PRTPHD SUBROUTINE 760u 788u WDMSFL (INTEGER) scalar 733s 739s 788r 788r 788r XQUAL (CHARACTER) array 732s 741s 794o 794o 795o 795o 797o 797o Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 26 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) ------------------------------------------------------------------------------------------------------------------------------- 14 763s 18 766s 785f 210 792d 799s 104 767s 802f 1010 777s 784f 1011 778s 789f 1012 779s 790f 1013 780s 794f 797f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 27 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PRTIN3 Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 808 C 809 C 810 C 811 SUBROUTINE PRTIN3 812 # ( MSG, NPKS, IPKSEQ,PKS, XQUAL, 813 $ GAGEB, IPKPTR, SYSPP, WRCPP , WEIBA, EMAOPT, WDMSFL ) 814 C 815 C + + + PURPOSE + + + 816 C PRINTS INPUT PEAKS IN INPUT ORDER AND IN RANKED ORDER 817 C WITH SYSTEMATIC AND WRC PLOTTING POSITIONS. 818 C 819 C NOTE -- THE PEAKS AND THEIR PLOTTING POSITIONS MUST 820 C BE LINED UP PROPERLY BY PREVIOUS CALLS TO SORTM 821 C AND ALIGNP. 822 C 823 C + + + DUMMY ARGUMENTS + + + 824 INTEGER MSG, NPKS, EMAOPT, WDMSFL 825 REAL PKS(NPKS), SYSPP(NPKS), WRCPP(NPKS), WEIBA 826 REAL GAGEB 827 INTEGER IPKSEQ(NPKS), IPKPTR(NPKS) 828 CHARACTER*(*) XQUAL(NPKS) 829 C 830 C + + + ARGUMENT DEFINITIONS + + + 831 C MSG - 832 C NPKS - 833 C IPKSEQ - 834 C PKS - 835 C XQUAL - 836 C GAGEB - 837 C IPKPTR - 838 C SYSPP - 839 C WRCPP - 840 C WEIBA - 841 C EMAOPT - indicator flag for performing EMA analysis 842 C 0 - no, just do traditional J407 843 C 1 - yes, run EMA 844 C WDMSFL - FORTRAN unit number for input WDM file 845 C 846 C + + + LOCAL VARIABLES + + + 847 INTEGER JLINE, I, NB, J, ILINE, ND2 848 REAL EPSILN 849 CHARACTER*8 ESTTYP(2) 850 C 851 C + + + INTRINSICS + + + 852 INTRINSIC ABS 853 C 854 C + + + EXTERNALS + + + 855 C EXTERNAL PRTPHD 856 C 857 C + + + FORMATS + + + 858 104 FORMAT(//8X,'Explanation of peak discharge qualification codes', 859 $//6X,' PEAKFQ WATSTORE', Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 860 $ /6X,' CODE CODE DEFINITION', 861 $//6X,' D 3 Dam failure, non-recurrent flow anomaly', 862 $ /6X,' G 8 Discharge greater than stated value', 863 $ /6X,' X 3+8 Both of the above', 864 $ /6X,' L 4 Discharge less than stated value', 865 $ /6X,' K 6 OR C Known effect of regulation or ', 866 $ 'urbanization', 867 $ /6X,' H 7 Historic peak' ///) 868 1010 FORMAT('1',//) 869 1011 FORMAT(//23X,'I N P U T D A T A L I S T I N G') 870 C1012 FORMAT(/ 23X,10HWATER YEAR,4X, 9HDISCHARGE, 871 C $ 9H CODES /) 872 1012 FORMAT(//,2(' WATER YEAR DISCHARGE CODES ')/) 873 C1013 FORMAT(20X,I10,F15.1, 1A10) 874 1013 FORMAT(2(I12,F15.1, 1A10)) 875 C1017 FORMAT(/33X,'-- CONTINUED --') 876 C 877 1021 FORMAT( //3X, 878 $ 'EMPIRICAL FREQUENCY CURVES -- ',A,' PLOTTING POSITIONS' 879 $ / 73X, A, '** WEIBA =', F6.3, ' ***' ) 880 Cprh 1022 FORMAT( 6X, 5HWATER, 9X, 6HRANKED, 7X, 881 Cprh $ 10HSYSTEMATIC, 6X,'BULL.17B'/ 882 Cprh $ 7X,4HYEAR, 7X, 9HDISCHARGE, 8X, 6HRECORD,8X,8HESTIMATE/) 883 1022 FORMAT(6X,'WATER',7X,' RANKED ',6X,'SYSTEMATIC',6X, A, / 884 $ 6X,' YEAR',7X,'DISCHARGE',6X,' RECORD ',6X,'ESTIMATE'/) 885 1023 FORMAT( I11,F15.1,2F15.4, 886 $ 2A1,T27,' -- ', 1A1, ' -- ' ) 887 C1027 FORMAT(/33X,'-- CONTINUED --') 888 C 889 C + + + DATA INITIALIZATIONS + + + 890 DATA EPSILN/1.0E-6/ 891 DATA ESTTYP/ 'BULL.17B' , ' EMA ' / 892 C 893 C + + + END SPECIFICATIONS + + + 894 C 895 C write table of observed data 896 WRITE(MSG,1010) 897 CALL PRTPHD ( 2001, -999, EMAOPT, WDMSFL ) 898 WRITE(MSG,1011) 899 WRITE(MSG,1012) 900 ND2 = (NPKS+1)/2 901 DO 210 I = 1,ND2 902 IF (I+ND2 .LE. NPKS) THEN 903 WRITE(MSG,1013) IPKSEQ(I), PKS(I), XQUAL(I), 904 $ IPKSEQ(I+ND2), PKS(I+ND2), XQUAL(I+ND2) 905 ELSE 906 WRITE(MSG,1013) IPKSEQ(I), PKS(I), XQUAL(I) 907 END IF 908 210 CONTINUE 909 C 910 C write key to codes 911 WRITE(MSG, 104 ) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 29 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 ------------------------------------------------------------- 912 C 913 C write table of frequency curves 914 WRITE(MSG,1010) 915 CALL PRTPHD ( 2001, -999, EMAOPT, WDMSFL ) 916 JLINE = 0 917 302 CONTINUE 918 ILINE = JLINE+1 919 C IF(ILINE.GT.1) WRITE(MSG,1027) 920 C CALL PRTPHD( 3000 , -999 ) 921 IF ( ABS(WEIBA).GT.EPSILN ) THEN 922 WRITE(MSG,1021) 'WEIBXXX', '*', WEIBA 923 ELSE 924 WRITE(MSG,1021) 'WEIBULL' 925 END IF 926 WRITE(MSG,1022) ESTTYP(EMAOPT + 1) 927 C IF(ILINE.GT.1)WRITE(MSG,1027) 928 JLINE = NPKS 929 C NLINES = JLINE-ILINE+1 930 C IF(NLINES.GT.40)JLINE = ILINE+34 931 C IF(NLINES.GT.50)JLINE = ILINE+39 932 DO 310 I = ILINE,JLINE 933 NB = 1 934 IF(IPKSEQ(IPKPTR(I)) .LT. 0) NB = 2 935 IF(PKS(IPKPTR(I)) .LE. GAGEB ) NB = 3 936 WRITE(MSG,1023) IPKSEQ(IPKPTR(I)), PKS(IPKPTR(I)), 937 * SYSPP(I), WRCPP(I) , 938 $ (' ',J=1,NB) 939 310 CONTINUE 940 IF(JLINE.LT.NPKS) GO TO 302 941 C 942 RETURN 943 END Bytes of stack required for this program unit: 112. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- EMAOPT (INTEGER) scalar 813s 824s 897r 915r 926u 897r 897r 915r 915r EPSILN (REAL) scalar 848s 890/ 921u ESTTYP (CHARACTER) array 849s 891/ 926o 926o GAGEB (REAL) scalar 813s 826s 935u I (INTEGER) scalar 847s 902u 903u 903u 903u 904u 904u 904u 906u 906u 906u 934u 935u 936u 936u 937u 937u ILINE (INTEGER) scalar 847s 918= 932u IPKPTR (INTEGER) array 813s 827s 934u 935u 936u 936u IPKSEQ (INTEGER) array 812s 827s 903o 904o 906o 934u 936o J (INTEGER) scalar 847s 938= 938u JLINE (INTEGER) scalar 847s 916= 918u 928= 932u 940u MSG (INTEGER) scalar 812s 824s 896o 898o 899o 903o 906o 911o 914o 922o 924o 926o 936o Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- NB (INTEGER) scalar 847s 933= 934= 935= 938o ND2 (INTEGER) scalar 847s 900= 901u 902u 904u 904u 904u NPKS (INTEGER) scalar 812s 824s 825u 825u 825u 827u 827u 828u 900u 902u 928u 940u PKS (REAL) array 812s 825s 903o 904o 906o 935u 936o PRTIN3 SUBROUTINE 811s PRTPHD SUBROUTINE 897u 915u SYSPP (REAL) array 813s 825s 937o WDMSFL (INTEGER) scalar 813s 824s 897r 915r 897r 897r 915r 915r WEIBA (REAL) scalar 813s 825s 921r 922o WRCPP (REAL) array 813s 825s 937o XQUAL (CHARACTER) array 812s 828s 903o 903o 904o 904o 906o 906o -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 210 901d 908s 310 932d 939s 302 917s 940g 104 858s 911f 1010 868s 896f 914f 1011 869s 898f 1021 877s 922f 924f 1012 872s 899f 1022 883s 926f 1013 874s 903f 906f 1023 885s 936f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 31 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PRTFIT 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 PRTFIT 948 # ( IDEBUG, EMAOPT, WDMSFL ) 949C 950C + + + PURPOSE + + + 951C PRINTS TABLUATED FITTED LOG-PEARSON TYPE III CURVE FOR J407. 952C 953C + + + HISTORY + + + 954C Updated 11/03 by PRH of AQUA TERRA Consultants for batch PEAKFQ 955C 956C + + + DUMMY ARGUMENTS + + + 957 INTEGER IDEBUG, EMAOPT, WDMSFL 958C 959C + + + ARGUMENT DEFINITIONS + + + 960C IDEBUG - 961C EMAOPT - indicator flag for performing EMA analysis 962C 0 - no, just do traditional J407 963C 1 - yes, run EMA 964C 965C + + + PARAMETERS + + + 966 INCLUDE 'pmxint.inc' 967C 968C + + + COMMON BLOCKS + + + 969 INCLUDE 'cwcf0.inc' 970 INCLUDE 'cwcf1.inc' 971 INCLUDE 'cwcf2.inc' 972C 973C + + + LOCAL VARIABLES + + + 974 CHARACTER*13 DWORK(5) 975 INTEGER I, J, SIGDIG, DECPLA, LEN 976 REAL PEP, TMP !, XTRPK 977C 978C + + + SAVES + + + 979 SAVE INITIP, IPLIST 980 INTEGER IPLIST(MXINT) 981C 982C + + + INTRINSICS + + + 983 INTRINSIC INT, EXP 984C 985C + + + EXTERNALS + + + 986 EXTERNAL SORTI, MOVEI, ZIPI, DECCHX !, QEXTRA 987C 988C + + + DATA INITIALIZATIONS + + + 989Cprh use INITIP flag to force init of IPLIST so that change to 990Cprh size of MXINT doesn't require update of this DATA statement 991Cprh DATA IPLIST / -777, 30*0 / 992 DATA INITIP / 0 / 993C 994C + + + FORMATS + + + 995 8 FORMAT(//1X,10X, 'ANNUAL FREQUENCY CURVE PARAMETERS -- ', Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 32 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 ------------------------------------------------------------- 996 $ 21HLOG-PEARSON TYPE III // 997 $' FLOOD BASE ', 998 $' LOGARITHMIC '/ 999 $' ----------------------', 1000 $' -------------------------------'/ 1001 $' EXCEEDANCE ', 1002 $' STANDARD '/ 1003 $' DISCHARGE PROBABILITY', 1004 $' MEAN DEVIATION SKEW '/18X,55('-')) 1005C 9 FORMAT( 5X,32HSYSTEMATIC PEAKS ABOVE BASE -- , 1006C $ 10X,2H--,2X,2F15.4,F15.3/ 1007C $ 6X,32HWRC-ADJUSTED PKS ABOVE BASE -- , 1008C $ 10X,2H--,2X,2F15.4,F15.3) 1009 9 FORMAT( /,' SYSTEMATIC PKS', 1010 $ /,' ABOVE BASE -- -- ',2F15.4,F15.3, 1011 $ /,' BULL.17B-ADJ PKS', 1012 $ /,' ABOVE BASE -- -- ',2F15.4,F15.3) 1013 10 FORMAT( ' SYSTEMATIC RECORD',F10.1,F11.4,F11.4,F12.4,F11.3 1014 $ /,' BULL.17B ESTIMATE',F10.1,F11.4,F11.4,F12.4,F11.3) 1015 15 FORMAT(///,' ANNUAL FREQUENCY CURVE -- DISCHARGES', 1016 $ ' AT SELECTED EXCEEDANCE PROBABILITIES', 1017 $ //,' ANNUAL ', 1018 $ ' ''EXPECTED ',I2,'-PCT CONFIDENCE LIMITS', 1019 $ /,' EXCEEDANCE BULL.17B SYSTEMATIC', 1020 $ ' PROBABILITY'' FOR BULL. 17B ESTIMATES', 1021 $ /,' PROBABILITY ESTIMATE RECORD ', 1022 $ ' ESTIMATE LOWER UPPER', / ) 1023 16 FORMAT(///,' ANNUAL FREQUENCY CURVE -- DISCHARGES', 1024 $ ' AT SELECTED EXCEEDANCE PROBABILITIES', 1025 $ //,' ANNUAL ', 1026 $ ' ''EXPECTED ',I2,'-PCT CONFIDENCE', 1027 $ /,' EXCEEDANCE EMA SYSTEMATIC', 1028 $ ' PROBABILITY'' LIMITS FOR EMA ESTIMATES', 1029 $ /,' PROBABILITY ESTIMATE RECORD ', 1030 $ ' ESTIMATE LOWER UPPER', / ) 1031 20 FORMAT(1X,F11.4, 5A ) 1032 1010 FORMAT('1',//) 1033 2011 FORMAT ( 1X, F11.4, 1X, ' -- ', 1034 $ 2X, '(', F6.2, '-year flood below base' ) 1035 2012 FORMAT ( 1X, F11.4, 1X, F12.1, 1036 $ 2X, '(', F6.2, '-year flood )' ) 1037C 203 FORMAT(1X,F12.1) 1038C 1039C + + + END SPECIFICATIONS + + + 1040C 1041C PRINT FITTED LOG-PEARSON TYPE III FREQUENCY CURVES PARAMETERS 1042C AND ORDINATES 1043 WRITE(MSG,1010) 1044 CALL PRTPHD ( 2001, -999, EMAOPT, WDMSFL ) 1045 WRITE(MSG,8) 1046 IF(IDEBUG.GT.0) WRITE(MSG,9) SYSAAV, SYSASD, SYSASK, 1047 $ WRCAAV,WRCASD,WRCASK Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 1048 SYSBAS = 10.**SYSBAS 1049 WRCBAS = 10.**WRCBAS 1050 WRITE(MSG,10)SYSBAS,SYSPAB,SYSUAV,SYSUSD,SYSSKW, 1051 $ WRCBAS,WRCPAB,WRCUAV,WRCUSD,WRCSKW 1052C 1053 IF (EMAOPT.EQ.0) THEN 1054C original B-17 estimates 1055 WRITE(MSG,15) INT( CLSIZE*100. + .5) 1056 ELSE 1057C new EMA estimates 1058 WRITE(MSG,16) INT( CLSIZE*100. + .5) 1059 END IF 1060C 1061 IF(INITIP .EQ. 0) THEN 1062 CALL MOVEI(INDXPT,IPLIST,NINDX) 1063 CALL SORTI(IPLIST,NINDX) 1064 INITIP = 1 1065 ENDIF 1066C 1067C fill in table, 4 significant digits, 1 decimal place and -- 1068C for no entries. DECCHX replaced intermal writes to get 1069C significant digits - aml 8/93 1070Ckmf list arrays 1071Ckmf write (99,3001) (iplist(i),10**wrcfc(i),10**sysrfc(i), 1072Ckmf $ 10**climl(i),10**climu(i), i = 1, mxint) 1073C3001 format ( 'PRTFIT:',/,' iplist wrcfc sysrfc ', 1074Ckmf $ ' climl climu ', 1075Ckmf $ / ( I8, 4X, 4f12.4 ) ) 1076 LEN = 13 1077 SIGDIG = 4 1078 DECPLA = 1 1079 DO 210 I = 1,NINDX 1080 DO 201 J = 1,5 1081 DWORK(J) = ' -- ' 1082 201 CONTINUE 1083 J = IPLIST(I) 1084 PEP = TXPROB(J) 1085 IF(PEP.LE.SYSPAB) THEN 1086C WRITE(DWORK(2),203) 10.**SYSRFC(J) 1087 TMP = 10.**SYSRFC(J) 1088CPRH TMP = EXP(SYSRFC(J)) 1089 CALL DECCHX (TMP,LEN,SIGDIG,DECPLA,DWORK(2)) 1090 IF (DWORK(2)(13:13) .EQ. ' ') DWORK(2)(13:13) = '0' 1091C IF(PEP.LE.WRCPAB) THEN 1092C changed 5/94 by aml in consultation with wt and wk 1093 IF(PEP.LT.WRCPAB) THEN 1094C WRITE(DWORK(1),203) 10.**WRCFC(J) 1095 TMP = 10.**WRCFC(J) 1096CPRH TMP = EXP(WRCFC(J)) 1097 CALL DECCHX (TMP,LEN,SIGDIG,DECPLA,DWORK(1)) 1098 IF (DWORK(1)(13:13) .EQ. ' ') DWORK(1)(13:13) = '0' 1099 IF(NOEPFC.NE.1) THEN Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 34 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 ------------------------------------------------------------- 1100C WRITE(DWORK(3),203) 10.**EPFC(J) 1101 IF (EPFC(J) .LT. 11.0) THEN 1102C number not to big for space 1103 write(99,*) 'PRTFIT: J,EPFC ',J,EPFC(J) 1104 TMP = 10.**EPFC(J) 1105 CALL DECCHX (TMP,LEN,SIGDIG,DECPLA,DWORK(3)) 1106 IF (DWORK(3)(13:13) .EQ. ' ') DWORK(3)(13:13) = '0' 1107 END IF 1108 END IF 1109 IF(NOCLIM.NE.1) THEN 1110C WRITE(DWORK(4),203) 10.**CLIML(J) 1111 TMP = 10.**CLIML(J) 1112CPRH TMP = EXP(CLIML(J)) 1113 CALL DECCHX (TMP,LEN,SIGDIG,DECPLA,DWORK(4)) 1114 IF (DWORK(4)(13:13) .EQ. ' ') DWORK(4)(13:13) = '0' 1115C WRITE(DWORK(5),203) 10.**CLIMU(J) 1116 TMP = 10.**CLIMU(J) 1117CPRH TMP = EXP(CLIMU(J)) 1118 CALL DECCHX (TMP,LEN,SIGDIG,DECPLA,DWORK(5)) 1119 IF (DWORK(5)(13:13) .EQ. ' ') DWORK(5)(13:13) = '0' 1120 END IF 1121 END IF 1122 WRITE(MSG,20) PEP, DWORK 1123 END IF 1124 210 CONTINUE 1125C 1126Ckmf Oct 3, 2000, in consultation with wrk 1127Ckmf call added to compute and print extra n-year floods 1128Cprh updated 11/03 for batch version of PEAKFQ that uses EMA method 1129Cprh calls to QEXTRA not needed since EMA calculates these intervals 1130Cprh TMP = 1.5 1131Cprh CALL QEXTRA ( TMP, XTRPK ) 1132Cprh IF (XTRPK .GT. 0) THEN 1133Cprh WRITE (MSG,2012) 1./TMP, XTRPK, TMP 1134Cprh ELSE 1135Cprh WRITE (MSG,2011) 1./TMP, TMP 1136Cprh END IF 1137Cprh TMP = 2.33 1138Cprh CALL QEXTRA ( TMP, XTRPK ) 1139Cprh IF (XTRPK .GT. 0) THEN 1140Cprh WRITE (MSG,2012) 1./TMP, XTRPK, TMP 1141Cprh ELSE 1142Cprh WRITE (MSG,2011) 1./TMP, TMP 1143Cprh END IF 1144C 1145 RETURN 1146 END Bytes of stack required for this program unit: 56. Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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) ------------------------------------------------------------------------------------------------------------------------------- BIGLOG (REAL) scalar 316 (I2)4s (I2)12s CLIML (REAL) array 256 (I3)2s (I3)4s 1111u CLIMU (REAL) array 384 (I3)3s (I3)5s 1116u CLSIZE (REAL) scalar 40 (I2)3s (I2)11s 1055u 1058u CPAMP1 (REAL) scalar 344 (I2)6s (I2)14s CPAMP2 (REAL) scalar 348 (I2)6s (I2)14s CPAMP3 (REAL) scalar 352 (I2)6s (I2)14s DECCHX SUBROUTINE 986u 1089u 1097u 1105u 1113u 1118u DECPLA (INTEGER) scalar 975s 1078= 1089r 1089r 1089r 1097r 1097r 1097r 1105r 1105r 1105r 1113r 1113r 1113r 1118r 1118r 1118r DWORK (CHARACTER) array 974s 1081= 1089r 1089r 1089r 1090u 1090= 1097r 1097r 1097r 1098u 1098= 1105r 1105r 1105r 1106u 1106= 1113r 1113r 1113r 1114u 1114= 1118r 1118r 1118r 1119u 1119= 1122o 1122o 1090i 1098i 1106i 1114i 1119i EMAOPT (INTEGER) scalar 948s 957s 1044r 1053u 1044r 1044r EPFC (REAL) array 128 (I3)2s (I3)4s 1101u 1103o 1104u EPS1 (REAL) scalar 320 (I2)5s (I2)13s EPS2 (REAL) scalar 324 (I2)5s (I2)13s GAGEB (REAL) scalar 12 (I4)2s (I4)10s GENSKU (REAL) scalar 0 (I4)2s (I4)10s GSKWGT (REAL) scalar 108 (I4)6s (I4)10s GSMAX (REAL) scalar 32 (I2)3s (I2)11s GSMIN (REAL) scalar 28 (I2)3s (I2)11s HISTPD (REAL) scalar 28 (I4)3s (I4)10s HISTPN (REAL) scalar 100 (I4)6s (I4)10s HISTWT (REAL) scalar 104 (I4)6s (I4)10s HRECWO (REAL) scalar 328 (I2)5s (I2)13s HRECWS (REAL) scalar 336 (I2)5s (I2)13s HRECWX (REAL) scalar 332 (I2)5s (I2)13s I (INTEGER) scalar 975s 1083u IDEBUG (INTEGER) scalar 948s 957s 1046u IGSOPT (INTEGER) scalar 4 (I4)2s (I4)9s INDX1 (INTEGER) scalar 44 (I2)4s (I2)9s INDX2 (INTEGER) scalar 48 (I2)4s (I2)9s INDXPT (INTEGER) array 56 (I2)4s (I2)9s 1062r 1062r 1062r INITIP (INTEGER) scalar 979s 992/ 1061u 1064= IPLIST (INTEGER) array 979s 980s 1062r 1062r 1062r 1063r 1063r 1063r 1083u IWXMOD (INTEGER) scalar 372 (I2)7s (I2)10s J (INTEGER) scalar 975s 1081u 1083= 1084u 1087u 1095u 1101u 1103o 1103u 1104u 1111u 1116u LEN (INTEGER) scalar 975s 1076= 1089r 1089r 1089r 1097r 1097r 1097r 1105r 1105r 1105r 1113r 1113r 1113r 1118r 1118r 1118r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 36 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 ------------------------------------------------------------- MOVEI SUBROUTINE 986u 1062u MSG (INTEGER) scalar 0 (I2)2s (I2)8s 1043o 1045o 1046o 1050o 1055o 1058o 1122o MSL (INTEGER) scalar 4 (I2)2s (I2)8s MXINT (INTEGER) scalar (I7)1s (I7)2s (I2)9u (I2)12u (I4)12u (I3)4u (I3)4u (I3)4u (I3)5u (I3)5u 980u NBGB (INTEGER) scalar 84 (I4)5s (I4)9s NHIOUT (INTEGER) scalar 92 (I4)5s (I4)9s NHIST (INTEGER) scalar 24 (I4)2s (I4)9s NHISTN (INTEGER) scalar 96 (I4)5s (I4)9s NINDX (INTEGER) scalar 52 (I2)4s (I2)9s 1062r 1062r 1062r 1063r 1063r 1063r 1079u NLWOUT (INTEGER) scalar 88 (I4)5s (I4)9s NMISS (INTEGER) scalar 76 (I4)5s (I4)9s NOCLIM (INTEGER) scalar 24 (I2)2s (I2)8s 1109u NOEPFC (INTEGER) scalar 20 (I2)2s (I2)8s 1099u NOPPOS (INTEGER) scalar 8 (I2)2s (I2)8s NOSYS (INTEGER) scalar 16 (I2)2s (I2)8s NOTRAN (INTEGER) scalar 12 (I2)2s (I2)8s NSYS (INTEGER) scalar 80 (I4)5s (I4)9s PEP (REAL) scalar 976s 1084= 1085u 1093u 1122o PRTFIT SUBROUTINE 947s PRTPHD SUBROUTINE 1044u QHIOUT (REAL) scalar 20 (I4)2s (I4)11s QLWOUT (REAL) scalar 16 (I4)2s (I4)11s RMSDGS (REAL) scalar 340 (I2)6s (I2)14s RMSEGS (REAL) scalar 8 (I4)2s (I4)10s SIGDIG (INTEGER) scalar 975s 1077= 1089r 1089r 1089r 1097r 1097r 1097r 1105r 1105r 1105r 1113r 1113r 1113r 1118r 1118r 1118r SIGHOT (REAL) scalar 360 (I2)7s (I2)15s SIGLOT (REAL) scalar 356 (I2)7s (I2)15s SORTI SUBROUTINE 986u 1063u SUMH (REAL(kind 8)) array 176 (I4)8s (I4)15s SUMS (REAL(kind 8)) array 152 (I4)8s (I4)15s SYSAAV (REAL) scalar 132 (I4)7s (I4)11s 1046o SYSASD (REAL) scalar 136 (I4)7s (I4)11s 1046o SYSASK (REAL) scalar 140 (I4)7s (I4)11s 1046o SYSBAS (REAL) scalar 112 (I4)6s (I4)11s 1048u 1048= 1050o SYSMAX (REAL) scalar 148 (I4)8s (I4)11s SYSMIN (REAL) scalar 144 (I4)8s (I4)12s SYSPAB (REAL) scalar 116 (I4)6s (I4)12s 1050o 1085u SYSRFC (REAL) array 512 (I3)3s (I3)5s 1087u SYSSKW (REAL) scalar 128 (I4)7s (I4)12s 1050o SYSUAV (REAL) scalar 120 (I4)6s (I4)12s 1050o SYSUSD (REAL) scalar 124 (I4)7s (I4)12s 1050o TMP (REAL) scalar 976s 1087= 1089r 1089r 1089r 1095= 1097r 1097r 1097r 1104= 1105r 1105r 1105r 1111= 1113r 1113r 1113r 1116= 1118r 1118r 1118r TXPROB (REAL) array 184 (I2)4s (I2)12s 1084u WCXAUX (REAL) array 364 (I2)7s (I2)15s WDMSFL (INTEGER) scalar 948s 957s 1044r 1044r 1044r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- WEIBA (REAL) scalar 36 (I2)3s (I2)11s WORK (REAL) array 200 (I4)8s (I4)12s WRCAAV (REAL) scalar 52 (I4)4s (I4)13s 1047o WRCASD (REAL) scalar 56 (I4)4s (I4)13s 1047o WRCASK (REAL) scalar 60 (I4)4s (I4)13s 1047o WRCBAS (REAL) scalar 32 (I4)3s (I4)13s 1049u 1049= 1051o WRCFC (REAL) array 0 (I3)2s (I3)4s 1095u WRCHHB (REAL) scalar 64 (I4)4s (I4)13s WRCHOT (REAL) scalar 68 (I4)4s (I4)13s WRCLOW (REAL) scalar 72 (I4)5s (I4)13s WRCPAB (REAL) scalar 36 (I4)3s (I4)14s 1051o 1093u WRCSKW (REAL) scalar 48 (I4)4s (I4)14s 1051o WRCUAV (REAL) scalar 40 (I4)3s (I4)14s 1051o WRCUSD (REAL) scalar 44 (I4)4s (I4)14s 1051o WSKLAT (REAL) scalar 312 (I2)4s (I2)12s ZIPI Procedure 986u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 1013s 1050f 20 1031s 1122f 15 1015s 1055f 16 1023s 1058f 210 1079d 1124s 201 1080d 1082s 8 995s 1045f 9 1009s 1046f 1010 1032s 1043f 2011 1033s 2012 1035s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 38 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE ALIGNP Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1147C 1148C 1149C 1150 SUBROUTINE ALIGNP 1151 # (IPKPTR, IPKSEQ, NPKS, NHIST, SYSPP) 1152C 1153C + + + PURPOSE + + + 1154C ALIGNS SYSTEMATIC-RECORD PROBABILITY-PLOTTING POSITIONS RETURNED 1155C BY WCFAGB WITH CORRESPONDING SYSTEMATIC-RECORD DISCHARGES IN THE 1156C SEQUENTIALLY ORDERED ARRAY OF INPUT SYSTEMATIC AND HISTORIC PEAKS. 1157C 1158C + + + DUMMY ARGUMENTS + + + 1159 INTEGER NPKS, NHIST 1160 INTEGER IPKPTR(NPKS), IPKSEQ(NPKS) 1161 REAL SYSPP(NPKS) 1162C 1163C + + + ARGUMENT DEFINITIONS + + + 1164C IPKPTR - ARRAY OF POINTERS FROM RANKED-PEAK LIST TO 1165C INPUT-SEQUENTIAL-ORDERED LIST. IPKPTR CAN BE SET BY 1166C CALLING SUBRTNE SORTM. 1167C IPKSEQ - ARRAY OF INPUT-SEQUENCE IDENTIFIERS. HISTORIC PEAKS 1168C HAVE NEGATIVE VALUES, SYSTEMATIC ONES, POSITIVE. 1169C NPKS - 1170C NHIST - 1171C SYSPP - 1172C 1173C + + + LOCAL VARIABLES + + + 1174 INTEGER IH, IS, I 1175C 1176C + + + END SPECIFICATIONS + + + 1177C 1178 IF(NHIST.GT.0) THEN 1179 IH = 0 1180 IS = 0 1181 DO 150 I = 1,NPKS 1182 IF(IPKSEQ(IPKPTR(I)).GT.0) THEN 1183 IS = IS+1 1184 SYSPP(I) = SYSPP(NHIST+IS) 1185 ELSE 1186 IH = IH+1 1187 SYSPP(I) = -1. 1188 IF(IH.GE.NHIST) GO TO 160 1189 END IF 1190 150 CONTINUE 1191 END IF 1192C 1193 160 CONTINUE 1194C 1195 RETURN 1196 END Bytes of stack required for this program unit: 40. Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- ALIGNP SUBROUTINE 1150s I (INTEGER) scalar 1174s 1182u 1184u 1187u IH (INTEGER) scalar 1174s 1179= 1186u 1186= 1188u IPKPTR (INTEGER) array 1151s 1160s 1182u IPKSEQ (INTEGER) array 1151s 1160s 1182u IS (INTEGER) scalar 1174s 1180= 1183u 1183= 1184u NHIST (INTEGER) scalar 1151s 1159s 1178u 1184u 1188u NPKS (INTEGER) scalar 1151s 1159s 1160u 1160u 1161u 1181u SYSPP (REAL) array 1151s 1161s 1184= 1184u 1187= -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 150 1181d 1190s 160 1188g 1193s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 40 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE INPUT Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1197C 1198C 1199C 1200 SUBROUTINE INPUT 1201 I (IA1,IA3,INFORM,MAXPKS,EMAOPT,WDMSFL, 1202 M ISTART, 1203 O STAID,PKSABG,IWYSN,XQUAL,IQUAL, 1204 O NHIST,NSYS,HISTPD, QHIOUT,QLWOUT,GAGEB, 1205 O GENSKU, RMSEGS,ISKUOP, NSKIP1, IRC ) 1206C 1207C + + + PURPOSE + + + 1208C RE-WRITTEN FOR PRIME VERSION 3.8-P, WK, 7/88. 1209C 1210C + + + DUMMY ARGUMENTS + + + 1211 INTEGER IA1,IA3, INFORM, MAXPKS, EMAOPT, WDMSFL, NHIST, 1212 & NSYS, ISKUOP, NSKIP1, IRC, ISTART 1213 INTEGER IWYSN(MAXPKS), IQUAL(MAXPKS) 1214 REAL PKSABG(MAXPKS) 1215 REAL HISTPD, QHIOUT, QLWOUT, GAGEB, GENSKU, RMSEGS 1216 CHARACTER*(*) STAID , XQUAL(MAXPKS) 1217C 1218C + + + ARGUMENT DEFINITIONS + + + 1219C IA1 - 1220C IA3 - 1221C INFORM - 1222C MAXPKS - 1223C EMAOPT - indicator flag for performing EMA analysis 1224C 0 - no, just do traditional J407 1225C 1 - yes, run EMA 1226C WDMSFL - FORTRAN unit number of input WDM file 1227C ISTART - 1228C STAID - 1229C PKSABG - 1230C IWYSN - 1231C XQUAL - 1232C IQUAL - 1233C NHIST - 1234C NSYS - 1235C HISTPD - 1236C QHIOUT - 1237C QLWOUT - 1238C GAGEB - 1239C GENSKU - 1240C RMSEGS - 1241C ISKUOP - 1242C NSKIP1 - 1243C IRC - 1244C 1245C + + + LOCAL VARIABLES + + + 1246 CHARACTER*90 IDSTA 1247 INTEGER I 1248C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 1249C + + + EXTERNALS + + + 1250 EXTERNAL INPUT1, INPUT2, INPUT3 1251C 1252C + + + END SPECIFICATIONS + + + 1253C 1254 IRC = 0 1255 NSKIP1 = 0 1256C 1257C 1258 IF ( INFORM .LE. 0 ) THEN 1259C do nothing 1260C 1261 ELSE IF ( INFORM .EQ. 1 ) THEN 1262 CALL INPUT1( IA1, IA3 , 1263 $ MAXPKS, STAID, PKSABG, IWYSN, XQUAL, 1264 $ NHIST,NSYS,HISTPD, QHIOUT,QLWOUT,GAGEB,GENSKU, 1265 $ RMSEGS,ISKUOP, NSKIP1, IRC ) 1266C 1267 ELSE IF ( INFORM .EQ. 2 ) THEN 1268 CALL INPUT2(IA1, MAXPKS, EMAOPT, WDMSFL, 1269 M ISTART, 1270 O STAID, PKSABG, IWYSN, XQUAL, IQUAL, 1271 O NHIST,NSYS,HISTPD, QHIOUT,QLWOUT,GAGEB, 1272 O GENSKU,RMSEGS,ISKUOP, NSKIP1, IRC ) 1273C 1274 ELSE IF ( INFORM .EQ. 3 ) THEN 1275 CALL INPUT3( MAXPKS, IDSTA,PKSABG, IWYSN, NHIST,NSYS,HISTPD, 1276 $ QHIOUT,QLWOUT,GAGEB,GENSKU,RMSEGS,ISKUOP, NSKIP1, IRC) 1277 WRITE( STAID, '(7X,A12,1X,A52)') IDSTA(1:12), IDSTA(13:64) 1278 DO 80 I = 1,(NHIST+NSYS) 1279 XQUAL(I) = ' -- ' 1280 80 CONTINUE 1281C 1282 ELSE 1283 STOP 233 1284 END IF 1285C 1286 RETURN 1287 END Bytes of stack required for this program unit: 112. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- EMAOPT (INTEGER) scalar 1201s 1211s 1268r 1268r 1268r GAGEB (REAL) scalar 1204s 1215s 1264r 1262r 1262r 1271r 1268r 1268r 1276r 1275r 1275r GENSKU (REAL) scalar 1205s 1215s 1264r 1262r 1262r 1272r 1268r 1268r 1276r 1275r 1275r HISTPD (REAL) scalar 1204s 1215s 1264r 1262r 1262r 1271r 1268r 1268r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 42 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 ------------------------------------------------------------- 1275r 1275r 1275r I (INTEGER) scalar 1247s 1279u IA1 (INTEGER) scalar 1201s 1211s 1262r 1262r 1262r 1268r 1268r 1268r IA3 (INTEGER) scalar 1201s 1211s 1262r 1262r 1262r IDSTA (CHARACTER) scalar 1246s 1275r 1275r 1275r 1277o 1277o 1277o 1277o INFORM (INTEGER) scalar 1201s 1211s 1258u 1261u 1267u 1274u INPUT SUBROUTINE 1200s INPUT1 SUBROUTINE 1250u 1262u INPUT2 SUBROUTINE 1250u 1268u INPUT3 SUBROUTINE 1250u 1275u IQUAL (INTEGER) array 1203s 1213s 1270r 1268r 1268r IRC (INTEGER) scalar 1205s 1212s 1254= 1265r 1262r 1262r 1272r 1268r 1268r 1276r 1275r 1275r ISKUOP (INTEGER) scalar 1205s 1212s 1265r 1262r 1262r 1272r 1268r 1268r 1276r 1275r 1275r ISTART (INTEGER) scalar 1202s 1212s 1269r 1268r 1268r IWYSN (INTEGER) array 1203s 1213s 1263r 1262r 1262r 1270r 1268r 1268r 1275r 1275r 1275r MAXPKS (INTEGER) scalar 1201s 1211s 1213u 1213u 1214u 1216u 1263r 1262r 1262r 1268r 1268r 1268r 1275r 1275r 1275r NHIST (INTEGER) scalar 1204s 1211s 1264r 1262r 1262r 1271r 1268r 1268r 1275r 1275r 1275r 1278u NSKIP1 (INTEGER) scalar 1205s 1212s 1255= 1265r 1262r 1262r 1272r 1268r 1268r 1276r 1275r 1275r NSYS (INTEGER) scalar 1204s 1212s 1264r 1262r 1262r 1271r 1268r 1268r 1275r 1275r 1275r 1278u PKSABG (REAL) array 1203s 1214s 1263r 1262r 1262r 1270r 1268r 1268r 1275r 1275r 1275r QHIOUT (REAL) scalar 1204s 1215s 1264r 1262r 1262r 1271r 1268r 1268r 1276r 1275r 1275r QLWOUT (REAL) scalar 1204s 1215s 1264r 1262r 1262r 1271r 1268r 1268r 1276r 1275r 1275r RMSEGS (REAL) scalar 1205s 1215s 1265r 1262r 1262r 1272r 1268r 1268r 1276r 1275r 1275r STAID (CHARACTER) scalar 1203s 1216s 1263r 1262r 1262r 1270r 1268r 1268r 1277o 1277o WDMSFL (INTEGER) scalar 1201s 1211s 1268r 1268r 1268r XQUAL (CHARACTER) array 1203s 1216s 1263r 1262r 1262r 1270r 1268r 1268r 1279= -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 80 1278d 1280s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 43 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE INPUT2 Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1288C 1289C 1290C 1291 SUBROUTINE INPUT2 1292 I ( MESSFL, MAXPKS, EMAOPT, WDMSFL, 1293 M ISTART, 1294 O STAID, PKSABG, IWYSN, XQUAL, IQUAL, 1295 O NHIST, NSYS, HISTPD, QHIOUT, QLWOUT, GAGEB, 1296 O GENSKU, RMSEGS, ISKUOP, NSKIP1, IRC ) 1297C 1298C + + + PURPOSE + + + 1299C GETS INPUT DATA FROM WATSTORE PEAK-FILE PUNCHED-CARD RETRIEVAL 1300C 1301C + + + HISTORY + + + 1302C ORIGINALLY WRITTEN AS INPUT3 FOR VECTOR-FORMAT PEAK FILE DATA. WK 5/79. 1303C REV 1/81 WK - FOR B-17-B - TO PASS RMSEGS DATA. 1304C RE-WRITTEN AS INPUT2 FOR PRIME VERSION 3.8. WK, 7/88. 1305C Updated for batch version of PEAKFQ, 9/03 1306C Paul Hummel of AQUA TERRA Consultants 1307C 1308C + + + DUMMY ARGUMENTS + + + 1309 INTEGER MAXPKS, NHIST, NSYS, ISKUOP, NSKIP1, IRC, ISTART 1310 INTEGER MESSFL, IWYSN(MAXPKS) , IQUAL(MAXPKS) 1311 INTEGER EMAOPT, WDMSFL 1312 REAL PKSABG(MAXPKS) 1313 REAL HISTPD, QHIOUT, QLWOUT, GAGEB, GENSKU, RMSEGS 1314 CHARACTER*(*) XQUAL(MAXPKS) 1315 CHARACTER*(*) STAID 1316C 1317C + + + ARGUMENT DEFINITIONS + + + 1318C MESSFL - Fortran unit number of AIDE message file 1319C ISTART - flag 1st time = 0, else > 0. 1320C EMAOPT - indicator flag for performing EMA analysis 1321C 0 - no, just do traditional J407 1322C 1 - yes, run EMA 1323C WDMSFL - FORTRAN unit number of input WDM file 1324C MAXPKS - MAX NUMBER OF PEAKS THAT CAN BE STORED IN DATA ARRAYS 1325C STAID - CHARACTER STRING STATION ID NO AND NAME -- 1326C 1-15 = 15-DIGIT STATION ID NO. (8-DIGIT D.S. ORDER NO, 1327C RIGHT JUST.) 1328C 16-20 = AGENCY CODE 1329C 21-78 = STATION NAME, LEFT JUSTIFIED. 1330C 79-90 = USED BY J407. 1331C PKSABG - FLOOD PEAK DISCHARGES -- 1332C HISTORICAL VALUES IN FIRST NHIST (IF ANY) 1333C FOLLOWED BY NSYS SYSTEMATIC PKS. 1334C IWYSN - WATER-YEARS OR SEQUENCE NUMBERS OF PKSABG PEAKS-- 1335C WATER-YRS OR SEQ NOS OF HISTORIC PEAKS ARE NEGATIVE-VALUED 1336C VALUES FOR SYSTEMATIC PKS ARE POSITIVE. 1337C XQUAL - QUALIFICATION CODES FOR PKSABG -- CHARACTER 1338C IQUAL - QUALIFICATION CODES FOR PKSABG -- INTEGER 1339C NHIST - NUMBER OF HISTORIC peaks returned Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 44 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 ------------------------------------------------------------- 1340C NSYS - number of systematic peaks 1341C HISTPD - LENGTH OF HISTORIC PERIOD 1342C QHIOUT - USER-SET HIGH- OUTLIER DISCHARGE THRESHOLDS 1343C QLWOUT - USER-SET low-outlier discharge threshold 1344C GAGEB - GAGE BASE DISCHARGE 1345C GENSKU - GENERALIZED SKEW 1346C RMSEGS - RMS ERROR OF GENERALIZED SKEW 1347C ISKUOP - GEN.SKEW OPTION -- 1= GEN SKU, 0=WTD SKU, -1= STA SKU. 1348C NSKIP1 - NUMBER OF STATIONS SKIPPED BECAUSE OF INPUT ERRORS 1349C IRC - RETURN CODE - 0=NO ERROR, 1=ERRORS, 2=END OF FILE, 3=BOTH 1350C 1351C + + + COMMON BLOCKS + + + 1352 INCLUDE 'clunit.inc' 1353 INCLUDE 'cjobop.inc' 1354C 1355C + + + LOCAL VARIABLES + + + 1356 REAL AUX(13), FLAT, FLONG, GAGEBT, XSYSPK,XHSTPK 1357 LOGICAL BIT(15) , NOHIST, REJECT 1358 CHARACTER*1 LQCODE(6) 1359 CHARACTER*4 LREG 1360Cprh CHARACTER*15 CD 1361 CHARACTER*18 CURSTA 1362 INTEGER MSG, NOBS, IBEGYR, IENDYR, IHOPTI, IKROPT, I, IBEGIN, 1363 & IEND, IPK, LOOPBK, OKFG 1364Cprh , K, L15, IRET, SCLU, SGRP, 1365Cprh $ IVAL(2), CVAL(3), L3, L2, L7, L4, L1, L8, 1366Cprh $ L6, L9, L10 1367C 1368C + + + FUNCTIONS + + + 1369 INTEGER IBITEX 1370 REAL WCFGSM 1371 LOGICAL DOSTATION 1372C 1373C + + + INTRINSICS + + + 1374 INTRINSIC AMAX1, ABS, INT 1375C 1376C + + + EXTERNALS + + + 1377 EXTERNAL PKFRD4, WCFGSM, IBITEX, LFTSTR 1378 EXTERNAL DOSTATION, PARSESTASPECS 1379Cprh EXERNAL Q1EDIT, Q1INIT, QGETR 1380Cprh EXTERNAL QSETR, QSETI, QGETI, QSETCO, QGETCO, QSTCTF 1381Cprh EXTERNAL ZSTCMA, QSETRB, QGETRB 1382C 1383C + + + DATA INITIALIZATIONS + + + 1384 DATA LQCODE /'D','L','K','H','G','X'/ 1385C 1386C + + + FORMATS + + + 1387 593 FORMAT(/' *** INPUT2 - HISTORIC PEAKS OVERFLOWED -',2I6, 1388 $ 3X, 30A1//' *** SKIPPING FOR NEXT STATION.') 1389 403 FORMAT(/' *** INPUT2 - PEAK COUNT EXCEEDS STORAGE CAPACITY', 1390 $ I9,2X,30A1//' *** SKIPPING FOR NEXT STATION') 1391 486 FORMAT(/' *** INPUT2 - REQUESTED YEARS NOT IN RECORD',4I8,3X, Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 1392 $ 30A1/ /' *** SKIPPING FOR NEXT STATION.') 1393 493 FORMAT(I4,'-',I4) 1394C 1395C + + + END SPECIFICATIONS + + + 1396C 1397 MSG = MSG1 1398Cprh L1 = 1 1399Cprh L2 = 2 1400Cprh L3 = 3 1401Cprh L4 = 4 1402Cprh L6 = 6 1403Cprh L7 = 7 1404Cprh L8 = 8 1405Cprh L9 = 9 1406Cprh L10= 10 1407Cprh L15= 15 1408 NSKIP1 = 0 1409 NSYS = 0 1410 NHIST = 0 1411Cprh SCLU = 121 1412C 1413 100 CONTINUE 1414 LOOPBK = 0 1415 CALL PKFRD4( INCRD, MSG1, MAXPKS, EMAOPT, WDMSFL, 1416 M ISTART, STAID, AUX, NOBS, PKSABG(21), 1417 M IQUAL(21), IWYSN(21), IRC, 1418 O XSYSPK, XHSTPK) 1419C note PKSABG are offset for space for historic peaks 1420C 1421 IF (IRC.LT.2) THEN 1422C not end of file so process 1423C 1424 IF(IRC.EQ.1) NSKIP1 = NSKIP1 + 1 1425C 1426 CURSTA = TRIM(STAID(1:15)) 1427 IF (ALLSOM .EQ. 2) THEN 1428C check to see if this is a station user wanted 1429 OKFG = 0 1430C call to DOSTATION will update argument CURSTA with an index 1431C if multiple instances of this station are encountered 1432 IF (DOSTATION(ISTART,CURSTA)) OKFG = 1 1433Cprh DO 110 K = 1,20 1434Cprh CD = DOSTA(K) 1435Cprh CALL LFTSTR(L15,CD) 1436Cprh IF (CS .EQ. CD) OKFG = 1 1437Cprh 110 CONTINUE 1438 ELSE 1439C do them all 1440 OKFG = 1 1441 END IF 1442C 1443 IF(NOBS+20.GT.MAXPKS .OR. OKFG .EQ. 0) THEN Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 46 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 ------------------------------------------------------------- 1444C too many peaks or 1445 IF (OKFG .EQ. 1) WRITE(MSG,403)NOBS, STAID(1:30) 1446 NSKIP1 = NSKIP1 + 1 1447 LOOPBK = 1 1448C 1449 ELSE 1450Cprh IF (IMODFG .EQ. 1) THEN 1451CprhC user wants to modify options 1452Cprh CALL ZSTCMA (16,1) 1453Cprh SGRP = 67 1454Cprh 120 CONTINUE 1455Cprh CALL Q1INIT (MESSFL, SCLU, SGRP) 1456Cprh IVAL(1) = INT(AUX(7)) 1457Cprh IVAL(2) = INT(AUX(8)) 1458Cprh CALL QSETI (L2,IVAL) 1459Cprh CVAL(2) = INT(AUX(11))+ 1 1460Cprh CVAL(1) = INT(AUX(9)) + 2 1461Cprh CALL QSETCO (L2,CVAL) 1462Cprh CALL QSETRB (L1,L1,AUX(2)) 1463Cprh CALL QSETRB (L2,L2,AUX(4)) 1464Cprh CALL QSETRB (L2,L4,AUX(12)) 1465Cprh CALL QSETRB (L1,L6,AUX(3)) 1466Cprh CALL QSETRB (L1,L7,XHSTPK) 1467Cprh CALL QSETRB (L1,L8,XSYSPK) 1468Cprh IF (AUX(1).LT.-9999.0 .AND. AUX(12).GT.0.0 .AND. 1469Cprh $ AUX(13).GT.0.0) THEN 1470Cprh AUX(1) = WCFGSM(AUX(12),AUX(13)) 1471Cprh END IF 1472Cprh IF (AUX(1).LT.-998.0) THEN 1473Cprh CALL QSETRB (L1,L9,-999.0) 1474Cprh ELSE 1475Cprh CALL QSETRB (L1,L9,AUX(1)) 1476Cprh END IF 1477Cprh CALL QSETRB (L1,L10,AUX(6)) 1478Cprh CALL QSTCTF (L3,L15,STAID(1:15)) 1479Cprh CALL Q1EDIT (IRET) 1480Cprh IF (IRET .EQ. -1) GO TO 120 1481Cprh CALL QGETI (L2, IVAL) 1482Cprh AUX(7) = REAL(IVAL(1)) 1483Cprh AUX(8) = REAL(IVAL(2)) 1484Cprh CALL QGETCO (L2,CVAL) 1485Cprh AUX(9) = REAL(CVAL(1)-2) 1486Cprh AUX(11)= REAL(CVAL(2)-1) 1487Cprh CALL QGETRB (L1,L1,AUX(2)) 1488Cprh CALL QGETRB (L2,L2,AUX(4)) 1489Cprh CALL QGETRB (L2,L4,AUX(12)) 1490Cprh CALL QGETRB (L1,L6,AUX(3)) 1491Cprh CALL QGETRB (L1,L9,AUX(1)) 1492Cprh IF (AUX(1) .LT. -998.0) THEN 1493Cprh AUX(1) = -1.01E29 1494Cprh END IF 1495Cprh CALL QGETRB (L1,L10,AUX(6)) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 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 ------------------------------------------------------------- 1496Cprh CALL ZSTCMA (16,0) 1497Cprh ELSE 1498Cprh IRET = 1 1499Cprh END IF 1500C 1501Cprh IF (IRET .NE. 7) THEN 1502C not too many peaks & user wants to continue 1503 GENSKU = AUX(1) 1504 HISTPD = AUX(2) 1505 QHIOUT = AUX(3) 1506 QLWOUT = AUX(4) 1507 GAGEB = AUX(5) 1508 RMSEGS = AUX(6) 1509 IBEGYR = AUX(7) 1510 IENDYR = AUX(8) 1511 IHOPTI = AUX(10) 1512 ISKUOP = AUX(9) 1513 IKROPT = AUX(11) 1514 FLAT = AUX(12) 1515 FLONG = AUX(13) 1516C 1517 IF( GENSKU .LT. -9999.9) GENSKU = WCFGSM(FLAT,FLONG) 1518 1519C update specs 1520 CALL PARSESTASPECS (CURSTA,XSYSPK,XHSTPK, 1521 M GENSKU,HISTPD,QHIOUT,QLWOUT, 1522 M GAGEB,RMSEGS,IBEGYR,IENDYR, 1523 M ISKUOP,IKROPT,FLAT,FLONG) 1524 1525C 1526 NOHIST = HISTPD.LE.0. .AND. QHIOUT.LE.0. .AND. IHOPTI.LE.0 1527 GAGEBT= 0. 1528C 1529C find first and last years of record 1530 IF(IENDYR.LE.0) IENDYR = 9999 1531 IF(IWYSN(20+NOBS).LT.IBEGYR. OR. IWYSN(21).GT.IENDYR) 1532 $ GO TO 485 1533C 1534 DO 470 I = 1, NOBS 1535 IF(IWYSN(20+I).GE.IBEGYR) GO TO 475 1536 470 CONTINUE 1537 GO TO 485 1538C 1539 475 CONTINUE 1540 IBEGIN = 20 + I 1541 DO 480 I=1,NOBS 1542 IF(IWYSN(21+NOBS-I).LE.IENDYR) GO TO 490 1543 480 CONTINUE 1544C 1545 485 CONTINUE 1546 WRITE(MSG,486)IBEGYR,IENDYR,IWYSN(21),IWYSN(20+NOBS), 1547 $ STAID(1:30) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 48 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 ------------------------------------------------------------- 1548 NSKIP1 = NSKIP1 + 1 1549 LOOPBK = 1 1550C 1551 490 CONTINUE 1552C 1553 IF (LOOPBK .EQ. 0) THEN 1554C first/last year within record continue processing 1555 IEND = 21 + NOBS - I 1556 WRITE(STAID(69:78), 493)IWYSN(IBEGIN), IWYSN(IEND) 1557C 1558C select peaks for input 1559 DO 590 IPK = IBEGIN, IEND 1560C examine quality codes 1561 DO 510 I = 1,15 1562 BIT( I ) = IBITEX(IQUAL(IPK), I) .NE. 0 1563 510 CONTINUE 1564 LREG = ' ' 1565 IF( BIT(3)) LREG(1:1) = LQCODE(1) 1566 IF(BIT( 8)) LREG(1:1) = LQCODE(5) 1567 IF(BIT( 8).AND.BIT(3)) LREG(1:1) = LQCODE(6) 1568 IF(BIT(4)) LREG(2:2) = LQCODE(2) 1569 IF(BIT(6).OR.BIT(12)) LREG(3:3) = LQCODE(3) 1570 IF(BIT(7)) LREG(4:4) = LQCODE(4) 1571 XQUAL(IPK) = LREG 1572C 1573C act on codes 1574 REJECT = PKSABG(IPK).LT.0. .OR. BIT(3) .OR. BIT( 8) 1575 $ .OR.((BIT(6).OR.BIT(12)) .AND. IKROPT.LE.0) 1576 REJECT = REJECT .OR. (BIT(7).AND.NOHIST) 1577 REJECT = REJECT .OR. (BIT(7).AND. 1578 $ PKSABG(IPK).LT.(QHIOUT+0.5) 1579 $ .AND. IHOPTI.LE.0) 1580 REJECT = REJECT .OR. (BIT(7) .AND. HISTPD.LE.0) 1581 IF( REJECT ) THEN 1582 PKSABG(IPK) = -( ABS(PKSABG(IPK))+1E-4 ) 1583C 1584 ELSE 1585 IF(BIT(4)) GAGEBT= AMAX1(GAGEBT,PKSABG(IPK)) 1586C 1587C move historic peaks 1588 IF(BIT(7)) THEN 1589 NHIST = NHIST + 1 1590 IWYSN (NHIST) = -IWYSN (IPK) 1591 PKSABG(NHIST) = PKSABG (IPK) 1592 XQUAL (NHIST) = XQUAL (IPK) 1593 IQUAL (IPK) = -999 1594C CODE IQUAL = -999 TO DENOTE MOVED HIST PEAK 1595 END IF 1596 END IF 1597 590 CONTINUE 1598C 1599 IF(GAGEB.LE.0.) GAGEB = GAGEBT Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 49 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 ------------------------------------------------------------- 1600C 1601 IF(NHIST.GT. IBEGIN) THEN 1602 WRITE(MSG,593) NHIST, IBEGIN, STAID(1:30) 1603 NSKIP1 = NSKIP1 + 1 1604 LOOPBK = 1 1605C 1606 ELSE 1607C CLOSE UP PEAKS FOR RETURN TO INPUT 1608 DO 630 IPK = IBEGIN, IEND 1609 IF(IQUAL(IPK).NE.-999) THEN 1610 NSYS = NSYS + 1 1611 XQUAL (NHIST+NSYS) = XQUAL (IPK) 1612 PKSABG (NHIST+NSYS) = PKSABG (IPK) 1613 IWYSN (NHIST+NSYS) = IWYSN (IPK) 1614 END IF 1615 630 CONTINUE 1616 END IF 1617C 1618 END IF 1619Cprh ELSE 1620CprhC user did an intrpt 1621Cprh LOOPBK = 0 1622Cprh IRC = 2 1623Cprh END IF 1624 END IF 1625C 1626 IF (LOOPBK .EQ. 1) GO TO 100 1627C 1628 END IF 1629C 1630 RETURN 1631 END Bytes of stack required for this program unit: 200. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- ALLSOM (INTEGER) scalar 44 (I1)4s (I1)7s 1427u AUX (REAL) array 1356s 1416r 1415r 1415r 1503u 1504u 1505u 1506u 1507u 1508u 1509u 1510u 1511u 1512u 1513u 1514u 1515u BIT (LOGICAL) array 1357s 1562= 1565u 1566u 1567u 1567u 1568u 1569u 1569u 1570u 1574u 1574u 1575u 1575u 1576u 1577u 1580u 1585u 1588u CURSTA (CHARACTER) scalar 1361s 1426= 1432r 1432r 1432r 1520r 1520r 1520r DOSTA (CHARACTER) array 48 (I1)4s (I1)9s DOSTATION FUNCTION 1371s 1378u 1432u EMAOPT (INTEGER) scalar 1292s 1311s 1415r 1415r 1415r FLAT (REAL) scalar 1356s 1514= 1517r 1517r 1517r 1523r 1520r 1520r FLONG (REAL) scalar 1356s 1515= 1517r 1517r 1517r 1523r 1520r 1520r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 50 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 ------------------------------------------------------------- GAGEB (REAL) scalar 1295s 1313s 1507= 1522r 1520r 1520r 1599u 1599= GAGEBT (REAL) scalar 1356s 1527= 1585r 1585r 1585= 1599u GENSKU (REAL) scalar 1296s 1313s 1503= 1517u 1517= 1521r 1520r 1520r GRFMT (CHARACTER) scalar 348 (I1)4s (I1)8s HISTPD (REAL) scalar 1295s 1313s 1504= 1521r 1520r 1520r 1526u 1580u I (INTEGER) scalar 1362s 1535u 1540u 1542u 1555u 1562u 1562r 1562r 1562r IBCPUN (INTEGER) scalar 4 (I1)2s (I1)5s IBEGIN (INTEGER) scalar 1362s 1540= 1556u 1559u 1601u 1602o 1608u IBEGYR (INTEGER) scalar 1362s 1509= 1522r 1520r 1520r 1531u 1535u 1546o IBITEX FUNCTION 1369s 1377u 1562u IDEBUG (INTEGER) scalar 12 (I1)2s (I1)5s IEND (INTEGER) scalar 1363s 1555= 1556u 1559u 1608u IENDYR (INTEGER) scalar 1362s 1510= 1522r 1520r 1520r 1530u 1530= 1531u 1542u 1546o IHOPTI (INTEGER) scalar 1362s 1511= 1526u 1579u IKROPT (INTEGER) scalar 1362s 1513= 1523r 1520r 1520r 1575u IMODFG (INTEGER) scalar 40 (I1)4s (I1)7s INCRD (INTEGER) scalar 4 (I5)2s (I5)3s 1415r 1415r 1415r INFIL2 (INTEGER) scalar 12 (I5)2s (I5)3s INFORM (INTEGER) scalar 16 (I5)2s (I5)3s INPUT2 SUBROUTINE 1291s IPK (INTEGER) scalar 1363s 1562u 1571u 1574u 1578u 1582u 1582u 1585u 1590u 1591u 1592u 1593u 1609u 1611u 1612u 1613u IPLTOP (INTEGER) scalar 0 (I1)2s (I1)5s IPPOS (INTEGER) scalar 16 (I1)2s (I1)5s IPRTOP (INTEGER) scalar 8 (I1)2s (I1)5s IPUNCH (INTEGER) scalar 8 (I5)2s (I5)3s IQUAL (INTEGER) array 1294s 1310s 1417r 1415r 1415r 1562r 1562r 1562r 1593= 1609u IRC (INTEGER) scalar 1296s 1309s 1417r 1415r 1415r 1421u 1424u ISKUDP (INTEGER) scalar 20 (I1)3s (I1)6s ISKUOP (INTEGER) scalar 1296s 1309s 1512= 1523r 1520r 1520r ISTART (INTEGER) scalar 1293s 1309s 1416r 1415r 1415r 1432r 1432r 1432r IWYSN (INTEGER) array 1294s 1310s 1417r 1415r 1415r 1531u 1531u 1535u 1542u 1546o 1546o 1556o 1556o 1590u 1590= 1613= 1613u JOBTTL (CHARACTER) scalar 0 (I1)11s (I1)12s LFTSTR Procedure 1377u LOOPBK (INTEGER) scalar 1363s 1414= 1447= 1549= 1553u 1604= 1626u LQCODE (CHARACTER) array 1358s 1384/ 1565u 1566u 1567u 1568u 1569u 1570u LREG (CHARACTER) scalar 1359s 1564= 1565= 1566= 1567= 1568= 1569= 1570= 1571u MAXPKS (INTEGER) scalar 1292s 1309s 1310u 1310u 1312u 1314u 1415r 1415r 1415r 1443u MESSFL (INTEGER) scalar 1292s 1310s MOROPT (INTEGER) array 32 (I1)3s (I1)6s MSG (INTEGER) scalar 1362s 1397= 1445o 1546o 1602o MSG1 (INTEGER) scalar 0 (I5)2s (I5)3s 1397u 1415r 1415r 1415r NHIST (INTEGER) scalar 1295s 1309s 1410= 1589u 1589= 1590u 1591u 1592u 1601u 1602o 1611u 1612u 1613u NOBS (INTEGER) scalar 1362s 1416r 1415r 1415r 1443u 1445o 1531u 1534u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 51 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 ------------------------------------------------------------- 1541u 1542u 1546u 1555u NOCLM (INTEGER) scalar 28 (I1)3s (I1)6s NOHIST (LOGICAL) scalar 1357s 1526= 1576u NOXPA (INTEGER) scalar 24 (I1)3s (I1)6s NSKIP1 (INTEGER) scalar 1296s 1309s 1408= 1424u 1424= 1446u 1446= 1548u 1548= 1603u 1603= NSYS (INTEGER) scalar 1295s 1309s 1409= 1610u 1610= 1611u 1612u 1613u OKFG (INTEGER) scalar 1363s 1429= 1432= 1440= 1443u 1445u PARSESTASPECS SUBROUTINE 1378u 1520u PKFRD4 SUBROUTINE 1377u 1415u PKSABG (REAL) array 1294s 1312s 1416r 1415r 1415r 1574u 1578u 1582r 1582= 1585r 1585r 1591= 1591u 1612= 1612u QHIOUT (REAL) scalar 1295s 1313s 1505= 1521r 1520r 1520r 1526u 1578u QLWOUT (REAL) scalar 1295s 1313s 1506= 1521r 1520r 1520r REJECT (LOGICAL) scalar 1357s 1574= 1576u 1576= 1577u 1577= 1580u 1580= 1581u RMSEGS (REAL) scalar 1296s 1313s 1508= 1522r 1520r 1520r SPCFUN (INTEGER) scalar 20 (I5)2s (I5)3s STAID (CHARACTER) scalar 1294s 1315s 1416r 1415r 1415r 1426r 1445o 1445o 1547o 1547o 1556o 1556o 1602o 1602o WCFGSM FUNCTION 1370s 1377u 1517u WDMSFL (INTEGER) scalar 1292s 1311s 1415r 1415r 1415r XHSTPK (REAL) scalar 1356s 1418r 1415r 1415r 1520r 1520r 1520r XQUAL (CHARACTER) array 1294s 1314s 1571= 1592= 1592u 1611= 1611u XSYSPK (REAL) scalar 1356s 1418r 1415r 1415r 1520r 1520r 1520r -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 100 1413s 1626g 510 1561d 1563s 630 1608d 1615s 470 1534d 1536s 480 1541d 1543s 490 1542g 1551s 590 1559d 1597s 403 1389s 1445f 493 1393s 1556f 593 1387s 1602f 475 1535g 1539s 485 1532g 1537g 1545s 486 1391s 1546f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 52 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PKFRD4 Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1632C 1633C 1634C 1635 SUBROUTINE PKFRD4 1636 I ( IN,MSG, MXPKS, EMAOPT, WDMSFL, 1637 M ISTART, STAID, AUX, NPKS, PKQ, 1638 M IPKQ, IWYEAR, IER, 1639 O XSYSPK, XHSTPK) 1640C 1641C + + + PURPOSE + + + 1642C Reads annual-peak discharge CARD-format retrieval data from 1643C AMDAHL/WATSTORE peak retrieval PGM. It also will handle 1644C WATSTORE/J407 I-CARDS that immediately follow the Y-CARD. 1645C 1646C IT IS ASSUMED THAT THE RETRIEVAL WAS DONE WITH RETRIEVAL 1647C OPTIONS IN THE M CARD AS FOLLOWS -- 1648C M-COL 47 = H -- HEADER RECORDS 1649C M-COL 48 = 3 -- TYPE-3 ANNUAL-PEAK RECORDS 1650C 1651C IF AN ERROR IS FOUND, THIS ROUTINE AUTOMATICALLY SKIPS TO 1652C THE START OF THE NEXT STATION. THUS IT ALWAYS RETURNS WITH 1653C A RECORD GOOD FOR PROCESSING, EXCEPT AT THE END OF THE FILE 1654C (IER .GE. 2). 1655C 1656C Bad cards (not Y,Z,N,H,I,2,3, or 4 on column 1) are reported 1657C on a temporary file (UNIT 91) and are appended to the output 1658C file. 1659C 1660C + + + DUMMY ARGUMENTS + + + 1661 INTEGER IN, MSG, MXPKS, NPKS, IER, EMAOPT, WDMSFL, ISTART 1662 INTEGER IPKQ(MXPKS), IWYEAR(MXPKS) 1663 REAL PKQ(MXPKS), AUX(*), XSYSPK, XHSTPK 1664 CHARACTER*(*) STAID 1665C 1666C + + + ARGUMENT DEFINITIONS + + + 1667C IN,MSG - LOGICAL UNIT NOS FOR INPUT AND MESSAGES 1668C EMAOPT - indicator flag for performing EMA analysis 1669C 0 - no, just do traditional J407 1670C 1 - yes, run EMA 1671C WDMSFL - FORTRAN unit number for input WDM file 1672C ISTART - initially 1, then incremented 1673C MXPKS - MAX ALLOWABLE NUMBER OF PEAKS TO BE RETRIEVED 1674C STAID - STATION IDENT -- 15-DIGIT STA NO, AGENCY CODE, NAME 1675C AUX - VECTOR OF AUX DATA, DIM 13 -- 1676C NPKS - NUMBER OF PEAKS ACTUALLY RETRIEVED 1677C PKQ - THE PEAK DISCHARGES ( -888 = BLANK IN FILE.) 1678C IPKQ - PEAK DISCHARGE QUALIFICATION CODES FROM WATSTORE 1679C STORED AS OCTAL-CODED DECIMAL INTEGER AS FOLLOWS -- 1680C WATSTORE CODE IPKQ-VALUE 1681C 1, 2, 3 1, 2, 4 1682C 4, 5, 6 10, 20, 40 1683C 7, 8, 9 100, 200, 400 Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 53 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 ------------------------------------------------------------- 1684C A, B, C 1000, 2000, 4000 1685C D, E, F 10000, 20000, 40000 1686C IPKQ = SUM OF IPKQ-VALUES. (USE ROUTINE IBITEX TO 1687C EXTRACT INDIVIDUAL BITS.) 1688C IWYEAR - INTEGER ARRAY OF WATER YEARS. 1689C IER - ERROR CODE 0=NONE, 1=SKIP, 2=END OF FILE, 3=BOTH. 1690C XSYSPK - highest systematic peak 1691C XHSTPK - lowest historic peak 1692C 1693C + + + SAVES + + + 1694 SAVE CARD 1695C 1696C + + + LOCAL VARIABLES + + + 1697 CHARACTER*80 CARD 1698 CHARACTER*48 NAME 1699 CHARACTER*5 AGENCY 1700 CHARACTER*15 STANO 1701 CHARACTER*9 PEAKQ 1702 CHARACTER*1 QCODE(14), COLD 1703 INTEGER IBITS(14), I2, AGAIN 1704 INTEGER I, J, MONTH, MINYR, MAXYR !, L15 1705 REAL FLAT, FLON, FS, FM 1706C 1707C + + + INTRINSICS + + + 1708 INTRINSIC ABS, REAL, LEN 1709C 1710C + + + FUNCTIONS + + + 1711 INTEGER IBITOX 1712C 1713C + + + EXTERNALS + + + 1714 EXTERNAL IBITOX, PRTPHD 1715 EXTERNAL LFTSTR, ZLJUST 1716C 1717C + + + DATA INITIALIZATIONS + + + 1718 DATA QCODE /'1','2','3','4','5','6','7','8','9', 1719 $ 'A','B','C','D','E' / 1720C 1721C + + + INPUT FORMATS + + + 1722 1000 FORMAT ( A ) 1723C 1724C + + + OUTPUT FORMATS + + + 1725 2000 FORMAT ( ' *** PKFRD4 - PEAK OVERFLOW. NPKS,MAX =', 2I5 ) 1726 2001 FORMAT ( ' CARD types 4, 2, and * are ignored', 1727 $ /, 1X, A ) 1728 2002 FORMAT ( ' Unrecognized CARD type.', 1729 $ ' Must be Y, Z, N, H, I, 2, 3, 4, or *.', 1730 $ /, ' (2, 4, and * records are ignored.)', 1731 $ /, 1X, A ) 1732 2003 FORMAT ( ' Error reading input lat. or long. on H card.', 1733 $ /, 1X, A ) 1734 2004 FORMAT ( ' Error reading I-card', 1735 $ /, 1X, A ) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 54 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 ------------------------------------------------------------- 1736 2005 FORMAT ( ' Error reading a 3 card.', 1737 $ /, 1X, A ) 1738 2010 FORMAT (//, ' Insufficient data to process, only', 1739 $ I2, ' peaks for station ', A ) 1740C 1741C + + + END SPECIFICATIONS + + + 1742C 1743C This routine requires station id on each card and at least 3 1744C peak flow values. Except for the first call, CARD is processed 1745C as the last input from the previous call. At least one N,Z or H 1746C card is required to establish the station number. 1747C 1748 IER = 0 1749 NPKS = 0 1750Cprh L15 = 0 1751C set Z,N,H card flags 1752 DO 6 I = 2,13 1753 AUX(I) = 0. 1754 6 CONTINUE 1755 AUX(1) = -1.01E29 1756 XHSTPK = 1.0E29 1757 XSYSPK = 0.0 1758 AGENCY = ' ' 1759 NAME = ' ' 1760 I2 = LEN(STAID) 1761 IF (I2 .GT. 0) THEN 1762 DO 7 I = 1,LEN(STAID) 1763 STAID(I:I) = ' ' 1764 7 CONTINUE 1765 END IF 1766C 1767 IF (ISTART .EQ. 0) THEN 1768C first call, no CARD value to process, so read one 1769 9 CONTINUE 1770 READ(IN, '(A)', END=998) CARD 1771Ckmf left-shift station number 1772Ckmf CALL LFTSTR ( L15, CARD(2:16) ) 1773 IF (CARD(1:1).EQ.'Z'.OR.CARD(1:1).EQ.'Y'.OR. 1774 $ CARD(1:1).EQ.'N'.OR.CARD(1:1).EQ.'H'.OR. 1775 $ CARD(1:1).EQ.'I'.OR.CARD(1:1).EQ.'3') THEN 1776 AGAIN = 0 1777 CALL ZLJUST( CARD(2:16) ) 1778 ELSE IF (CARD(1:1).EQ.'4'.OR.CARD(1:1).EQ.'2'.OR. 1779 $ CARD(1:1).EQ.'*') THEN 1780C skip partial duration peak, 2, and comment records 1781 WRITE (91,2001) CARD 1782 AGAIN = 1 1783 ELSE 1784C unrecognized card type 1785 WRITE (91,2002) CARD 1786 AGAIN = 1 1787 END IF Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 55 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 ------------------------------------------------------------- 1788 IF (AGAIN .EQ. 1) GO TO 9 1789 ISTART = ISTART + 1 1790 END IF 1791 STANO = CARD(2:16) 1792C 1793 IF(CARD .NE. '$EOF') THEN 1794C last CARD not end of file 1795 MINYR = 2020 1796 MAXYR = 0 1797C 1798 10 CONTINUE 1799 IF(CARD(1:1) .EQ. 'Z') THEN 1800 AGENCY = CARD(33:37) 1801C 1802 ELSE IF(CARD(1:1) .EQ. 'H' ) THEN 1803 STANO = CARD(2:16) 1804 READ(CARD(17:22),'(3F2.0)',ERR=20) FLAT,FM,FS 1805 AUX(12) = FLAT+FM/60.+FS/3600. 1806 READ(CARD(23:29),'(F3.0,2F2.0)',ERR=20) FLON,FM,FS 1807 AUX(13) = FLON +FM/60.+FS/3600. 1808C 1809 GO TO 21 1810 20 CONTINUE 1811C Error reading input lat. or long. on H card. 1812 WRITE (MSG,2003) CARD 1813 21 CONTINUE 1814C 1815 ELSE IF(CARD(1:1).EQ.'N') THEN 1816 NAME = CARD(17:64) 1817 STANO = CARD(2:16) 1818C 1819 ELSE IF(CARD(1:1) .EQ. 'Y') THEN 1820C do nothing 1821C 1822 ELSE IF (CARD(1:1) .EQ. 'I') THEN 1823C READ OPTIONAL I-CARD 1824 IF(CARD(2:16).EQ.' ' 1825 $ .OR. CARD(2:16).EQ.STANO) THEN 1826 IF(CARD(2:16).EQ.' ') THEN 1827C put stano in blank space 1828 CARD(2:16) = STANO 1829 END IF 1830 READ(CARD,91,ERR=98)(AUX(I),I=1,8) 1831 91 FORMAT(16X,6F8.0,T71,2F4.0) 1832 IF(CARD(17:24) .EQ. ' ') AUX(1) = -1.01E29 1833 DO 95 I=65,69 1834 IF(CARD(I:I) .EQ. 'H' ) AUX(10) = 1.1 1835 IF(CARD(I:I) .EQ. 'G' ) AUX( 9) = 1.1 1836 IF(CARD(I:I) .EQ. 'S' ) AUX( 9) = -1.1 1837 IF(CARD(I:I) .EQ. 'K' ) AUX(11) = 1.1 1838 95 CONTINUE 1839C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 56 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 ------------------------------------------------------------- 1840 GO TO 99 1841 98 CONTINUE 1842C error reading an I card 1843 WRITE (MSG,2004) CARD 1844 99 CONTINUE 1845C 1846 END IF 1847C 1848 ELSE IF(CARD(1:1).EQ.'3') THEN 1849 NPKS = NPKS + 1 1850 IF(NPKS.GT.MXPKS) THEN 1851C peak overflow 1852 IER = 1 1853 WRITE (MSG,2000) NPKS, MXPKS 1854 ELSE 1855 READ(CARD(17:22),'(I4,I2)',ERR=140) IWYEAR(NPKS), MONTH 1856 IF(MONTH.GE.10) IWYEAR(NPKS) = IWYEAR(NPKS) + 1 1857 PEAKQ = CARD(25:31) 1858 READ(PEAKQ,'(F7.0)',ERR=140) PKQ(NPKS) 1859 IF(PEAKQ.EQ.' ') PKQ(NPKS) = -8888. 1860C 1861C EXTRACT PEAK--Q QUAL CODES 1862 DO 118 I=1,14 1863 IBITS(I) = 0 1864 118 CONTINUE 1865 DO 130 I = 32,43 1866 IF(CARD(I:I).NE.' ') THEN 1867 DO 120 J = 1,14 1868 IF(CARD(I:I).EQ.QCODE(J)) THEN 1869 IBITS(J) = 1 1870 END IF 1871 120 CONTINUE 1872 END IF 1873 130 CONTINUE 1874C find lowest historic and highest systematic 1875 IF (IBITS(7) .EQ. 1) THEN 1876C historic peak 1877 IF (XHSTPK .GT. PKQ(NPKS)) XHSTPK = PKQ(NPKS) 1878 ELSE 1879C systematic peak 1880 IF (XSYSPK .LT. PKQ(NPKS)) XSYSPK = PKQ(NPKS) 1881 END IF 1882C set local start/end of systematic record 1883 IF (IWYEAR(NPKS) .GT. MAXYR) MAXYR = IWYEAR(NPKS) 1884 IF (IWYEAR(NPKS) .LT. MINYR) MINYR = IWYEAR(NPKS) 1885 IPKQ(NPKS) = IBITOX(IBITS,14) 1886C 1887 GO TO 141 1888 140 CONTINUE 1889C error reading 3 card 1890 WRITE (MSG,2005) CARD 1891 141 CONTINUE Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 57 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 ------------------------------------------------------------- 1892 END IF 1893 END IF 1894C 1895C set old card type 1896 COLD = CARD(1:1) 1897C read new card 1898 150 CONTINUE 1899 READ(IN, '(A)', END=998) CARD 1900Ckmf left-shift station number 1901Ckmf CALL LFTSTR ( L15, CARD(2:16) ) 1902 IF (CARD(1:1).EQ.'Z'.OR.CARD(1:1).EQ.'Y'.OR. 1903 $ CARD(1:1).EQ.'N'.OR.CARD(1:1).EQ.'H'.OR. 1904 $ CARD(1:1).EQ.'I'.OR.CARD(1:1).EQ.'3') THEN 1905 AGAIN = 0 1906 CALL ZLJUST( CARD(2:16) ) 1907 ELSE IF (CARD(1:1).EQ.'4'.OR.CARD(1:1).EQ.'2'.OR. 1908 $ CARD(1:1).EQ.'*') THEN 1909C skip partial duration peak, 2, and comment records 1910 WRITE (91,2001) CARD 1911 AGAIN = 1 1912 ELSE 1913C unrecognized card type 1914 WRITE (91,2002) CARD 1915 AGAIN = 1 1916 END IF 1917 IF (AGAIN .EQ. 1) GO TO 150 1918C 1919C check conditions for looping back to process the new card 1920 IF (CARD(2:16).EQ.STANO .AND. IER.EQ.0) GO TO 10 1921 IF (CARD(1:1).EQ.'I'.AND.STANO.EQ.' ') 1922 & GO TO 10 1923 IF (COLD .EQ. 'Z') GO TO 10 1924C 1925C must be new station or too many peaks 1926C 1927 IF (NPKS .LT. 3) THEN 1928C insufficient data to process 1929 IF (NPKS .GT. 0) THEN 1930 IF(STANO.EQ.' ') STANO='unknown ' 1931 WRITE (MSG,2010) NPKS, STANO 1932 CALL PRTPHD (1000,1,EMAOPT,WDMSFL) 1933 END IF 1934 NPKS = 0 1935 ELSE 1936 STAID = STANO//AGENCY//NAME 1937 END IF 1938C 1939 IF (NPKS .EQ. 0) GO TO 10 1940C 1941 ELSE 1942C end of file 1943 IER = IER + 2 Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 58 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 ------------------------------------------------------------- 1944 END IF 1945C 1946 GO TO 999 1947 998 CONTINUE 1948C reached end of file 1949 CARD = '$EOF' 1950 STAID = STANO//AGENCY//NAME 1951 IF (NPKS .LT. 5) IER = IER + 2 1952 999 CONTINUE 1953C 1954C check if start/end on I card, if not, use systematic record 1955 IF (ABS(AUX(7)) .LT. 1.0) AUX(7) = REAL(MINYR) 1956 IF (ABS(AUX(8)) .LT. 1.0) AUX(8) = REAL(MAXYR) 1957 IF (ABS(AUX(6)) .LT. 0.00001) AUX(6) = 0.55 1958Cprh IF (XHSTPK .GT. 1.0E29) XHSTPK = 0.0 1959 IF (XHSTPK .GE. 1.0E29) XHSTPK = 0.0 1960C 1961 RETURN 1962 END Bytes of stack required for this program unit: 360. -------------------------------------------------- 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 1703s 1776= 1782= 1786= 1788u 1905= 1911= 1915= 1917u AGENCY (CHARACTER) scalar 1699s 1758= 1800= 1936u 1950u AUX (REAL) array 1637s 1663s 1753= 1755= 1805= 1807= 1830i 1832= 1834= 1835= 1836= 1837= 1955r 1955= 1956r 1956= 1957r 1957= CARD (CHARACTER) scalar 1694s 1697s 1770i 1770i 1773u 1773u 1774u 1774u 1775u 1775u 1777r 1777r 1777r 1778u 1778u 1779u 1781o 1781o 1785o 1785o 1791u 1793u 1799u 1800u 1802u 1803u 1804i 1804i 1806i 1806i 1812o 1812o 1815u 1816u 1817u 1819u 1822u 1824u 1825u 1826u 1828= 1830i 1830i 1832u 1834u 1835u 1836u 1837u 1843o 1843o 1848u 1855i 1855i 1857u 1866u 1868u 1890o 1890o 1896u 1899i 1899i 1902u 1902u 1903u 1903u 1904u 1904u 1906r 1906r 1906r 1907u 1907u 1908u 1910o 1910o 1914o 1914o 1920u 1921u 1949= 1773i 1773i 1773i 1773i 1773i 1773i 1778i 1778i 1778i 1793i 1799i 1802i 1815i 1819i 1822i 1824i 1824i 1826i 1832i 1834i 1835i 1836i 1837i 1848i 1866i 1868i 1902i 1902i 1902i 1902i 1902i 1902i 1907i 1907i 1907i 1920i 1921i COLD (CHARACTER) scalar 1702s 1896= 1923u 1923i EMAOPT (INTEGER) scalar 1636s 1661s 1932r 1932r 1932r FLAT (REAL) scalar 1705s 1804i 1805u FLON (REAL) scalar 1705s 1806i 1807u FM (REAL) scalar 1705s 1804i 1805u 1806i 1807u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 59 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 ------------------------------------------------------------- FS (REAL) scalar 1705s 1804i 1805u 1806i 1807u I (INTEGER) scalar 1704s 1753u 1763u 1763u 1830= 1830u 1830u 1834u 1834u 1835u 1835u 1836u 1836u 1837u 1837u 1863u 1866u 1866u 1868u 1868u I2 (INTEGER) scalar 1703s 1760= 1761u IBITOX FUNCTION 1711s 1714u 1885u IBITS (INTEGER) array 1703s 1863= 1869= 1875u 1885r 1885r 1885r IER (INTEGER) scalar 1638s 1661s 1748= 1852= 1920u 1943u 1943= 1951u 1951= IN (INTEGER) scalar 1636s 1661s 1770i 1899i IPKQ (INTEGER) array 1638s 1662s 1885= ISTART (INTEGER) scalar 1637s 1661s 1767u 1789u 1789= IWYEAR (INTEGER) array 1638s 1662s 1855i 1856u 1856= 1883u 1883u 1884u 1884u J (INTEGER) scalar 1704s 1868u 1869u LFTSTR Procedure 1715u MAXYR (INTEGER) scalar 1704s 1796= 1883u 1883= 1956r MINYR (INTEGER) scalar 1704s 1795= 1884u 1884= 1955r MONTH (INTEGER) scalar 1704s 1855i 1856u MSG (INTEGER) scalar 1636s 1661s 1812o 1843o 1853o 1890o 1931o MXPKS (INTEGER) scalar 1636s 1661s 1662u 1662u 1663u 1850u 1853o NAME (CHARACTER) scalar 1698s 1759= 1816= 1936u 1950u NPKS (INTEGER) scalar 1637s 1661s 1749= 1849u 1849= 1850u 1853o 1855u 1856u 1856u 1858u 1859u 1877u 1877u 1880u 1880u 1883u 1883u 1884u 1884u 1885u 1927u 1929u 1931o 1934= 1939u 1951u PEAKQ (CHARACTER) scalar 1701s 1857= 1858i 1858i 1859u 1859i PKFRD4 SUBROUTINE 1635s PKQ (REAL) array 1637s 1663s 1858i 1859= 1877u 1877u 1880u 1880u PRTPHD SUBROUTINE 1714u 1932u QCODE (CHARACTER) array 1702s 1718/ 1868u 1868i STAID (CHARACTER) scalar 1637s 1664s 1760r 1762r 1763= 1936= 1950= STANO (CHARACTER) scalar 1700s 1791= 1803= 1817= 1825u 1828u 1920u 1921u 1930u 1930= 1931o 1931o 1936u 1950u 1824i 1920i 1921i 1930i WDMSFL (INTEGER) scalar 1636s 1661s 1932r 1932r 1932r XHSTPK (REAL) scalar 1639s 1663s 1756= 1877u 1877= 1959u 1959= XSYSPK (REAL) scalar 1639s 1663s 1757= 1880u 1880= ZLJUST SUBROUTINE 1715u 1777u 1906u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 1798s 1920g 1922g 1923g 1939g 20 1804g 1806g 1810s 21 1809g 1813s 91 1830f 1831s 95 1833d 1838s 98 1830g 1841s 99 1840g 1844s 120 1867d 1871s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 60 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 ------------------------------------------------------------- 130 1865d 1873s 140 1855g 1858g 1888s 150 1898s 1917g 141 1887g 1891s 118 1862d 1864s 998 1770g 1899g 1947s 999 1946g 1952s 6 1752d 1754s 7 1762d 1764s 9 1769s 1788g 1000 1722s 2000 1725s 1853f 2010 1738s 1931f 2001 1726s 1781f 1910f 2002 1728s 1785f 1914f 2003 1732s 1812f 2004 1734s 1843f 2005 1736s 1890f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 61 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE INPUT3 Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 1963C 1964C 1965C 1966 SUBROUTINE INPUT3 1967 # ( MAXPKS, IDSTA, PKSABG, IWYSN, NHIST,NSYS, 1968 $ HISTPD, QHIOUT,QLWOUT,GAGEB,GENSKU,RMSEGS,ISKUOP, 1969 $ NSKIP, IRC ) 1970C 1971C + + + PURPOSE + + + 1972C INPUT FROM WATSTORE LOG-PEARSON CARD FORMAT 1973C -- NOTE -- THIS DOES NOT HAVE FULL ERROR-DETECTION AND OPTION- 1974C SETTING CAPABILITIES OF THE WATSTORE J407 VERSION. 1975C REWRITTEN FOR PRIME VERSION 3.8-P, WK, 7/88. 1976C 1977C + + + DUMMY ARGUMENTS + + + 1978 INTEGER MAXPKS, NHIST, NSYS, NSKIP, IRC, ISKUOP 1979 INTEGER IWYSN(MAXPKS) 1980 CHARACTER*(*) IDSTA 1981 REAL PKSABG(MAXPKS) 1982 REAL HISTPD, QHIOUT, QLWOUT, GAGEB, GENSKU, RMSEGS 1983C 1984C + + + ARGUMENT DEFINITIONS + + + 1985C MAXPKS - 1986C IDSTA - 1987C PKSABG - 1988C IWYSN - 1989C NHIST - 1990C NSYS - 1991C HISTPD - 1992C QHIOUT - 1993C QLWOUT - 1994C GAGEB - 1995C GENSKU - 1996C RMSEGS - 1997C ISKUOP - 1998C NSKIP - 1999C IRC - 2000C 2001C + + + COMMON BLOCKS + + + 2002 INCLUDE 'clunit.inc' 2003C 2004C + + + LOCAL VARIABLES + + + 2005 INTEGER I, NPK 2006C 2007C + + + EXTERNALS + + + 2008 EXTERNAL PKFQH3 2009C 2010C + + + END SPECIFICATIONS + + + 2011C 2012 NSKIP = 0 2013 100 CONTINUE 2014 CALL PKFQH3(INCRDS,MSG, MAXPKS, IDSTA,GAGEB,GENSKU,ISKUOP,NSYS, Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 62 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 ------------------------------------------------------------- 2015 $ RMSEGS,QLWOUT,QHIOUT,HISTPD,NHIST,PKSABG,IRC) 2016 IF(IRC.GT.1) RETURN 2017 NPK=NHIST+NSYS 2018 IF(NPK.GT.0) GO TO 120 2019 WRITE(MSG,111) IDSTA(1:64) 2020 111 FORMAT(/53H ***INPUT2 - STATION HAS NO PEAK FLOW DATA. STA-ID = / 2021 $ 12X,A64) 2022 NSKIP = NSKIP+1 2023 GO TO 100 2024 120 CONTINUE 2025C ASSIGN WATER-YEAR SEQ NOS. 2026 IF(NHIST.LT.0) NHIST = 0 2027 IF(NHIST.LE.0) GO TO 150 2028 DO 130 I=1,NHIST 2029 130 IWYSN(I) = I-1-NHIST 2030 150 CONTINUE 2031 DO 160 I=1,NSYS 2032 160 IWYSN(NHIST+I) = I 2033C 2034 RETURN 2035 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) ------------------------------------------------------------------------------------------------------------------------------- GAGEB (REAL) scalar 1968s 1982s 2014r 2014r 2014r GENSKU (REAL) scalar 1968s 1982s 2014r 2014r 2014r HISTPD (REAL) scalar 1968s 1982s 2015r 2014r 2014r I (INTEGER) scalar 2005s 2029u 2029u 2032u 2032u IDSTA (CHARACTER) scalar 1967s 1980s 2014r 2014r 2014r 2019o 2019o INCRD (INTEGER) scalar 4 (I5)2s (I5)3s INCRDS (INTEGER) scalar 2014r 2014r 2014r INFIL2 (INTEGER) scalar 12 (I5)2s (I5)3s INFORM (INTEGER) scalar 16 (I5)2s (I5)3s INPUT3 SUBROUTINE 1966s IPUNCH (INTEGER) scalar 8 (I5)2s (I5)3s IRC (INTEGER) scalar 1969s 1978s 2015r 2014r 2014r 2016u ISKUOP (INTEGER) scalar 1968s 1978s 2014r 2014r 2014r IWYSN (INTEGER) array 1967s 1979s 2029= 2032= MAXPKS (INTEGER) scalar 1967s 1978s 1979u 1981u 2014r 2014r 2014r MSG (INTEGER) scalar 2014r 2014r 2014r 2019o MSG1 (INTEGER) scalar 0 (I5)2s (I5)3s NHIST (INTEGER) scalar 1967s 1978s 2015r 2014r 2014r 2017u 2026u 2026= 2027u 2028u 2029u 2032u NPK (INTEGER) scalar 2005s 2017= 2018u NSKIP (INTEGER) scalar 1969s 1978s 2012= 2022u 2022= NSYS (INTEGER) scalar 1967s 1978s 2014r 2014r 2014r 2017u 2031u PKFQH3 SUBROUTINE 2008u 2014u PKSABG (REAL) array 1967s 1981s 2015r 2014r 2014r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 63 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 ------------------------------------------------------------- QHIOUT (REAL) scalar 1968s 1982s 2015r 2014r 2014r QLWOUT (REAL) scalar 1968s 1982s 2015r 2014r 2014r RMSEGS (REAL) scalar 1968s 1982s 2015r 2014r 2014r SPCFUN (INTEGER) scalar 20 (I5)2s (I5)3s -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 100 2013s 2023g 120 2018g 2024s 130 2028d 2029s 150 2027g 2030s 160 2031d 2032s 111 2019f 2020s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 64 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PKFQH3 Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2036C 2037C 2038C 2039 SUBROUTINE PKFQH3 2040 # ( IN,MSG, MAXPK,IDSTA,GAGEB,GENSKU,IGSOPT,NSYS, 2041 $ RMSEGS, 2042 $ QLWOUT,QHIOUT,HISTPD,NHIST,PKQ,IRC) 2043C 2044C + + + PURPOSE + + + 2045C READS LOG-PEARSON-FORMAT FLOOD DATA CARDS + HISTORIC/OUTLIER DATA 2046C CARDS FOR J407 VER 2.0. THIS VERSION HAS MINIMAL ERROR DETECTION 2047C AND RECOVERY. 2048C REV 1/16/81 WK. FOR J407 VER 3.5 HISTORIC/OUTLIER/GAGEB + RMSEGS. 2049C REV 7/88 WK. FOR VERS 3.8-P, MOVED 'IN,MSG' TO ARG LIST. 2050C 2051C + + + DUMMY ARGUMENTS + + + 2052 INTEGER IN, MSG, MAXPK, IGSOPT, NSYS, NHIST, IRC 2053 REAL GAGEB, GENSKU, RMSEGS, QLWOUT, QHIOUT, HISTPD 2054 REAL PKQ(*) 2055 CHARACTER*(*) IDSTA 2056C 2057C + + + LOCAL VARIABLES + + + 2058 CHARACTER*1 HH, HG, HS, HW, HN, OPT(5) 2059 CHARACTER*4 DEND, DEOD 2060 CHARACTER*8 BLANK 2061 CHARACTER*10 CID 2062 INTEGER I, J, J1, J2, IERNO, IHIOP, NCARD 2063 REAL FNHIST 2064C 2065C + + + DATA INITIALIZATION + + + 2066 DATA HH,HN,HG,HW,HS/'H','N','G','W','S'/ 2067 DATA DEND,BLANK,DEOD/'$END',' ','$EOD'/ 2068C 2069C + + + END SPECIFICATIONS + + + 2070C 2071 IRC = 0 2072 CID = '**********' 2073 IDSTA(1:1)=HH 2074 IDSTA(2:51)=' ' 2075 IDSTA(52:90)=' ' 20761000 CONTINUE 2077 GAGEB = 0. 2078 QHIOUT = 0. 2079 QLWOUT = 0. 2080 HISTPD = 0. 2081 NHIST = 0 2082 READ(IN,1) IDSTA(13:64),RMSEGS,GENSKU,OPT,NSYS,IDSTA(1:10) 2083 1 FORMAT(A52 ,2F5.0,5A1,I3,A10) 2084 IF(IDSTA(1:10).EQ.CID) GO TO 1000 2085 IF(IDSTA(13:16).EQ.DEND.OR.IDSTA(13:16).EQ.DEOD) GO TO 970 2086 IF(NSYS.EQ.0)RETURN 2087 IERNO = 3 Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 65 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 ------------------------------------------------------------- 2088 IF(NSYS.LT.0.OR.NSYS.GT.MAXPK) GO TO 900 2089 IHIOP = 0 2090 IGSOPT = 0 2091 DO10I = 1,5 2092 IF(OPT(I).EQ.HH)IHIOP = 1 2093 IF(OPT(I).EQ.HN)IHIOP = 0 2094 IF(OPT(I).EQ.HG)IGSOPT = +1 2095 IF(OPT(I).EQ.HS)IGSOPT = -1 2096 IF(OPT(I).EQ.HW)IGSOPT = 0 2097 10 CONTINUE 2098 IERNO = 5 2099 NCARD = (NSYS+9)/10 2100 DO30I = 1,NCARD 2101 J2 = 10*I + IHIOP*15 2102 J1 = J2-9 2103 READ(IN,2)(PKQ(J),J = J1,J2),CID 2104 2 FORMAT(10F7.0,A10) 2105 IF(CID(1:10).NE.IDSTA(1:10)) GO TO 900 2106 30 CONTINUE 2107 IF(IHIOP.NE.0) GO TO 40 2108 RETURN 2109 40 READ(IN,2)GAGEB,QLWOUT,QHIOUT,HISTPD,FNHIST,(PKQ(J),J = 1,5),CID 2110 NHIST = FNHIST 2111 IERNO = 203 2112 IF(NHIST.LT.0.OR.NHIST.GT.15.) GO TO 900 2113 IERNO = 205 2114 IF((CID(1:8).NE.IDSTA(1:8)) 2115 $ .AND. (CID(1:8).NE.BLANK(1:8))) GO TO 900 2116 IF(NHIST.LE.5) GO TO 50 2117 READ(IN,2)(PKQ(J),J = 6,15),CID 2118 IF((CID(1:8).NE.IDSTA(1:8)) 2119 $ .AND. (CID(1:8).NE.BLANK(1:8))) GO TO 900 2120 50 CONTINUE 2121 DO60I = 1,NSYS 2122 60 PKQ(NHIST+I) = PKQ(15+I) 2123 RETURN 2124 900 WRITE(MSG,901)IERNO,CID,IDSTA(1:10) 2125 901 FORMAT(/37H *** PKFQH3 ERROR AT CARD-ID, STA-ID.,I5, 2126 $ 2(3X,1H-,A10 ,1H-),A10/10X, 2127 $58HERROR CODES 3,203=INVALID PEAK COUNTS. 5,205=ID MISMATCH./) 2128 IRC = 1 2129 GO TO 1000 2130 970 IRC = IRC+2 2131 RETURN 2132 END Bytes of stack required for this program unit: 144. -------------------------------------------------- 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:18 2004 Page: 66 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 ------------------------------------------------------------- BLANK (CHARACTER) scalar 2060s 2067/ 2115u 2119u 2114i 2118i CID (CHARACTER) scalar 2061s 2072= 2084u 2103i 2103i 2105u 2109i 2109i 2114u 2115u 2117i 2117i 2118u 2119u 2124o 2124o 2084i 2105i 2114i 2114i 2118i 2118i DEND (CHARACTER) scalar 2059s 2067/ 2085u 2085i DEOD (CHARACTER) scalar 2059s 2067/ 2085u 2085i FNHIST (REAL) scalar 2063s 2109i 2110u GAGEB (REAL) scalar 2040s 2053s 2077= 2109i GENSKU (REAL) scalar 2040s 2053s 2082i HG (CHARACTER) scalar 2058s 2066/ 2094u 2094i HH (CHARACTER) scalar 2058s 2066/ 2073u 2092u 2092i HISTPD (REAL) scalar 2042s 2053s 2080= 2109i HN (CHARACTER) scalar 2058s 2066/ 2093u 2093i HS (CHARACTER) scalar 2058s 2066/ 2095u 2095i HW (CHARACTER) scalar 2058s 2066/ 2096u 2096i I (INTEGER) scalar 2062s 2092u 2093u 2094u 2095u 2096u 2101u 2122u 2122u IDSTA (CHARACTER) scalar 2040s 2055s 2073= 2074= 2075= 2082i 2082i 2082i 2082i 2084u 2085u 2085u 2105u 2114u 2118u 2124o 2124o 2084i 2085i 2085i 2105i 2114i 2118i IERNO (INTEGER) scalar 2062s 2087= 2098= 2111= 2113= 2124o IGSOPT (INTEGER) scalar 2040s 2052s 2090= 2094= 2095= 2096= IHIOP (INTEGER) scalar 2062s 2089= 2092= 2093= 2101u 2107u IN (INTEGER) scalar 2040s 2052s 2082i 2103i 2109i 2117i IRC (INTEGER) scalar 2042s 2052s 2071= 2128= 2130u 2130= J (INTEGER) scalar 2062s 2103= 2103u 2103u 2109= 2109u 2109u 2117= 2117u 2117u J1 (INTEGER) scalar 2062s 2102= 2103i J2 (INTEGER) scalar 2062s 2101= 2102u 2103i MAXPK (INTEGER) scalar 2040s 2052s 2088u MSG (INTEGER) scalar 2040s 2052s 2124o NCARD (INTEGER) scalar 2062s 2099= 2100u NHIST (INTEGER) scalar 2042s 2052s 2081= 2110= 2112u 2112u 2116u 2122u NSYS (INTEGER) scalar 2040s 2052s 2082i 2086u 2088u 2088u 2099u 2121u OPT (CHARACTER) array 2058s 2082i 2082i 2092u 2093u 2094u 2095u 2096u 2092i 2093i 2094i 2095i 2096i PKFQH3 SUBROUTINE 2039s PKQ (REAL) array 2042s 2054s 2103i 2109i 2117i 2122= 2122u QHIOUT (REAL) scalar 2042s 2053s 2078= 2109i QLWOUT (REAL) scalar 2042s 2053s 2079= 2109i RMSEGS (REAL) scalar 2041s 2053s 2082i -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 2091d 2097s 30 2100d 2106s 40 2107g 2109s 50 2116g 2120s 60 2121d 2122s 900 2088g 2105g 2112g 2115g 2119g 2124s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 67 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 ------------------------------------------------------------- 970 2085g 2130s 901 2124f 2125s 1 2082f 2083s 2 2103f 2104s 2109f 2117f 1000 2076s 2084g 2129g Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 68 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE OUTPUT Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2133C 2134C 2135C 2136 SUBROUTINE OUTPUT 2137 # (STAID,SYSUAV,SYSUSD,SYSSKW, 2138 $ WRCUAV,WRCUSD,WRCSKW,WRCFC , NHSTPN, NSYS, 2139 $ IBCPUN, LBCPU, IA1,IA3, PAUSE ) 2140C 2141C + + + PURPOSE + + + 2142C WRITES OUTPUT OF J407 RESULTS TO FILE SELECTED BY IBCPUN - 2143C 2144C + + + HISTORY + + + 2145C kmf 96/12/17 - changed ibcpu to ibcpun to be consistent, 2146C simplified check for wdm and/or basin char 2147C 2148C + + + DUMMY ARGUMENTS + + + 2149 CHARACTER*90 STAID 2150 REAL WRCFC(*),SYSUSD, SYSSKW, WRCUAV, WRCUSD, WRCSKW, 2151 & SYSUAV 2152 INTEGER NHSTPN, NSYS, IBCPUN, LBCPU, IA1, IA3, PAUSE 2153C 2154C + + + ARGUMENT DEFINITIONS + + + 2155C IBCPUN - indicator flag for writing calculated statistics 2156C 0 - don't save 2157C 1 - save as attributes in wdm file 2158C 2 - save in WATSTORE basin characteristics format 2159C 3 - save in wdm file (1) and WATSTORE (2) 2160C 2161C + + + EXTERNALS + + + 2162 EXTERNAL OUTPT1, BCFPCH 2163C 2164C + + + END SPECIFICATIONS + + + 2165C 2166 IF (IBCPUN .EQ. 1 .OR. IBCPUN .EQ. 3) THEN 2167C save statistics in wdm file 2168 CALL OUTPT1 (STAID,SYSUAV,SYSUSD,SYSSKW, 2169 $ WRCUAV,WRCUSD,WRCSKW,WRCFC,NHSTPN, NSYS, 2170 $ IA1,IA3, PAUSE ) 2171 END IF 2172 IF (IBCPUN .EQ. 2 .OR. IBCPUN .EQ. 3) THEN 2173C save statistics in watstore basin characteristics format 2174 CALL BCFPCH (STAID,SYSUAV,SYSUSD,SYSSKW, 2175 $ WRCUAV,WRCUSD,WRCSKW,WRCFC,NHSTPN, NSYS, LBCPU) 2176 END IF 2177C 2178 RETURN 2179 END Bytes of stack required for this program unit: 64. Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 69 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) ------------------------------------------------------------------------------------------------------------------------------- BCFPCH SUBROUTINE 2162u 2174u IA1 (INTEGER) scalar 2139s 2152s 2170r 2168r 2168r IA3 (INTEGER) scalar 2139s 2152s 2170r 2168r 2168r IBCPUN (INTEGER) scalar 2139s 2152s 2166u 2166u 2172u 2172u LBCPU (INTEGER) scalar 2139s 2152s 2175r 2174r 2174r NHSTPN (INTEGER) scalar 2138s 2152s 2169r 2168r 2168r 2175r 2174r 2174r NSYS (INTEGER) scalar 2138s 2152s 2169r 2168r 2168r 2175r 2174r 2174r OUTPT1 SUBROUTINE 2162u 2168u OUTPUT SUBROUTINE 2136s PAUSE (INTEGER) scalar 2139s 2152s 2170r 2168r 2168r STAID (CHARACTER) scalar 2137s 2149s 2168r 2168r 2168r 2174r 2174r 2174r SYSSKW (REAL) scalar 2137s 2150s 2168r 2168r 2168r 2174r 2174r 2174r SYSUAV (REAL) scalar 2137s 2151s 2168r 2168r 2168r 2174r 2174r 2174r SYSUSD (REAL) scalar 2137s 2150s 2168r 2168r 2168r 2174r 2174r 2174r WRCFC (REAL) array 2138s 2150s 2169r 2168r 2168r 2175r 2174r 2174r WRCSKW (REAL) scalar 2138s 2150s 2169r 2168r 2168r 2175r 2174r 2174r WRCUAV (REAL) scalar 2138s 2150s 2169r 2168r 2168r 2175r 2174r 2174r WRCUSD (REAL) scalar 2138s 2150s 2169r 2168r 2168r 2175r 2174r 2174r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 70 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE BCFPCH Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2180C 2181C 2182C 2183 SUBROUTINE BCFPCH 2184 # ( STAID,SYSAV,SYSSD,SYSG, WRCAV, WRCSD, 2185 $ GWRC, WRCFC, NHSTYR, NSYSYR, IPCH) 2186C 2187C + + + PURPOSE + + + 2188C PUNCHES J407 RESULTS IN BASIN-CHARACTERISTICS INPUT FORMAT 2189C ON LOGICAL UNIT IPCH 2190C 2191C + + + DUMMY ARGUMENTS + + + 2192 CHARACTER*90 STAID 2193 REAL WRCFC(*), SYSAV, SYSSD, SYSG, WRCAV, WRCSD, 2194 & GWRC 2195 INTEGER NHSTYR, NSYSYR, IPCH 2196C 2197C + + + LOCAL VARIABLES + + + 2198 CHARACTER*7 CHAR(9) 2199 INTEGER JPUN(9) 2200 INTEGER VAR (9) 2201 INTEGER I, IX 2202 REAL X, POWER 2203C 2204C + + + INTRINSICS + + + 2205 INTRINSIC INT 2206C 2207C + + + DATA INITIALIZATIONS + + + 2208Cprh DATA JPUN /12,16,20,21,23,25,26,27,28/ 2209Cprh updated for inclusion of 1.5 and 2.33 intervals, 11/03 2210 DATA JPUN /12,17,21,22,24,26,27,28,29/ 2211 DATA VAR /75,76,77,78,79,80,81,82,178/ 2212C 2213C + + + END SPECIFICATIONS + + + 2214C 2215C ROUND AND CONVERT USING FORMATS AND CHAR ARRAY 2216 DO 70 I=1,9 2217 X=10.**WRCFC(JPUN(I)) 2218 IF(X.LT.99.95 .OR. X.GE.9995000.) GO TO 50 2219 POWER=1. 2220 40 IX=(X/POWER)+.5 2221 IF(IX.LE.1000) GO TO 60 2222 POWER=10.*POWER 2223 GO TO 40 2224 50 WRITE(CHAR(I) , 51)X 2225 51 FORMAT(1F7.1) 2226 GO TO 70 2227 60 IX=IX*INT(POWER) 2228 WRITE(CHAR(I) , 61)IX 2229 61 FORMAT(1I7) 2230 70 CONTINUE 2231C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 71 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 ------------------------------------------------------------- 2232Ckmf add staion name record ("2" card) Oct 02, 2000 2233Ckmf station name is defined as being 21-78, space for 21-62 2234 WRITE (IPCH,100) STAID(1:15), STAID(21:62) 2235 100 FORMAT('1', A15, 4X, A ) 2236C PUNCH 3 CARDS 2237 WRITE(IPCH,101)STAID(1:15),(VAR(I),CHAR(I),I=1,6) 2238 101 FORMAT('2', A15,6(I3,1A7)) 2239 WRITE(IPCH, 102) STAID(1:15),(VAR(I),CHAR(I),I=7,8),SYSAV,SYSSD, 2240 $ SYSG, VAR(9), CHAR(9) 2241 102 FORMAT('2', A15,2(I3,1A7),' 83',F7.3,' 84',F7.3,' 85',F7.3, 2242 $ I3, 1A7) 2243 IX = 2 2244 IF(NHSTYR.GT.NSYSYR) IX = 1 2245 WRITE(IPCH, 103)STAID(1:15),GWRC,WRCAV,WRCSD , 2246 $ NSYSYR, NHSTYR, (' ',I=1,IX) 2247 103 FORMAT('2', A15,'179',F7.3, '180',F7.3,'181',F7.3 , 2248 $ '196',I7, '197',I7, 2A1,T57, 10X) 2249 RETURN 2250 END Bytes of stack required for this program unit: 80. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- BCFPCH SUBROUTINE 2183s CHAR (CHARACTER) array 2198s 2224o 2224o 2228o 2228o 2237o 2237o 2239o 2239o 2240o 2240o GWRC (REAL) scalar 2185s 2194s 2245o I (INTEGER) scalar 2201s 2217u 2224u 2228u 2237= 2237u 2237u 2237u 2239= 2239u 2239u 2239u 2246= 2246u IPCH (INTEGER) scalar 2185s 2195s 2234o 2237o 2239o 2245o IX (INTEGER) scalar 2201s 2220= 2221u 2227u 2227= 2228o 2243= 2244= 2246o JPUN (INTEGER) array 2199s 2210/ 2217u NHSTYR (INTEGER) scalar 2185s 2195s 2244u 2246o NSYSYR (INTEGER) scalar 2185s 2195s 2244u 2246o POWER (REAL) scalar 2202s 2219= 2220u 2222u 2222= 2227r STAID (CHARACTER) scalar 2184s 2192s 2234o 2234o 2234o 2234o 2237o 2237o 2239o 2239o 2245o 2245o SYSAV (REAL) scalar 2184s 2193s 2239o SYSG (REAL) scalar 2184s 2193s 2240o SYSSD (REAL) scalar 2184s 2193s 2239o VAR (INTEGER) array 2200s 2211/ 2237o 2239o 2240o WRCAV (REAL) scalar 2184s 2193s 2245o WRCFC (REAL) array 2185s 2193s 2217u WRCSD (REAL) scalar 2184s 2193s 2245o X (REAL) scalar 2202s 2217= 2218u 2218u 2220u 2224o Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 72 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) ------------------------------------------------------------------------------------------------------------------------------- 40 2220s 2223g 50 2218g 2224s 60 2221g 2227s 70 2216d 2226g 2230s 51 2224f 2225s 61 2228f 2229s 100 2234f 2235s 101 2237f 2238s 102 2239f 2241s 103 2245f 2247s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 73 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE PLTFRQ Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2251C 2252C 2253C 2254 SUBROUTINE PLTFRQ 2255 # ( MSG, HEADNG, IPLTOP, GRFMT, 2256 $ NPKPLT, PKLOG, SYSPP, WRCPP, WEIBA, 2257 $ SYSRFC,WRCFC,FCXPG,NPLOT,IWXMOD,HSTFLG, 2258 $ NOCLIM, CLIML, CLIMU, IPLTNO ) 2259C 2260C + + + PURPOSE + + + 2261C PRODUCES FREQUENCY-CURVE PLOT 2262C USES IPLTOP VALUE TO DETERMINE WHETHER PRINTER-PLOT 2263C OR GRAPHICS-DEVICE PLOT. 2264C 2265C 2266C + + + DUMMY ARGUMENTS + + + 2267 INTEGER IPLTOP, NPKPLT, NPLOT, MSG,IWXMOD, 2268 & HSTFLG, NOCLIM, IPLTNO 2269 CHARACTER*3 GRFMT 2270 CHARACTER*80 HEADNG(9) 2271 REAL PKLOG(*), SYSPP(*), WRCPP(*), SYSRFC(*), WRCFC(*), 2272 $ FCXPG(*), WEIBA, CLIML(*), CLIMU(*) 2273C 2274C + + + ARGUMENT DEFINITIONS + + + 2275C MSG - LOGICAL UNIT NUMBER FOR PRINT-PLOT 2276C HEADNG - PAGE-HEADING LINES FOR PLOT -- SAME AS ON PRINTOUT 2277C IPLTOP - 2278C GRFMT - graphic format (BMP, CGM, or WMF) 2279C NPKPLT - NUMBER OF OBSERVED PEAKS TO PLOT 2280C PKLOG - LOG-10 OBSERVED PEAK DISCHARGES 2281C SYSPP - SDYSTEMATIC-RECORD standard deviates (ENTRIES FOR 2282C HISTORIC PEAKS = -large) 2283C WRCPP - WRC-ESTIMATED standard deviates 2284C WEIBA - 2285C SYSRFC - LOG-10 ORDINATES OF FITTED CURVE - SYSTEMATIC RECORD 2286C WRCRFC - LOG-10 ORDINATES OF FITTED CURVE - WRC ESTIMATED 2287C FCXPG - TABULAR ABSCISSA PROBABILITIES FOR FITTED CURVE 2288C NPLOT - NUMBER OF PLOT POINTS IN FITTED CURVE 2289C IWXMOD - 2290C HSTFLG - flag to plot historic adjusted peaks, 0-yes, 1-no 2291C NOCLIM - flag for confidence limits, 0-available, 1-not available 2292C CLIML - log10 ordinates of fitted curve, lower confidence limits 2293C CLIMU - log10 ordinates of fitted curve, upper confidence limits 2294C IPLTNO - sequence number of this station (for identifying plots) 2295C 2296C + + + LOCAL VARIALBES + + + 2297 INTEGER IPRTPL, IGKSPL, DEVCOD | WARNING -- INTEGER scalar (DEVCOD) is never used. 2298 REAL EPSILN 2299 CHARACTER*3 PLTEXT Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 74 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 ------------------------------------------------------------- 2300C 2301C + + + INTRINSICS + + + 2302 INTRINSIC MOD, ABS 2303C 2304C + + + EXTERNALS + + + 2305 EXTERNAL FRQPLG, FRQPLT 2306 EXTERNAL GPINIT, GPDEVC 2307C 2308C + + + DATA INITIALIZATIONS + + + 2309 DATA EPSILN/1.0E-6/ 2310C 2311C + + + END SPECIFICATIONS + + + 2312C 2313 IGKSPL = MOD(IPLTOP,2) 2314 IPRTPL = MOD(IPLTOP/2,2) 2315C 2316 IF (IPRTPL .EQ. 1 ) THEN 2317 WRITE(MSG, '(''1''/(25X,A))' ) HEADNG 2318 IF (ABS(WEIBA) .GT. EPSILN) THEN 2319 WRITE(MSG,'(85X,A,F6.3,A)') '*** WEIBXXX PLOTTING, WEIBA =', 2320 $ WEIBA,'***' 2321 ELSE 2322 WRITE(MSG,*)' ' 2323 END IF 2324 CALL FRQPLT( MSG, 2325 $ NPKPLT, PKLOG, SYSPP, WRCPP, 2326 $ SYSRFC,WRCFC,FCXPG,NPLOT,IWXMOD) 2327 END IF 2328C 2329 IF (IGKSPL .EQ. 1) THEN 2330Cprh always generate BMP graphic files 2331C set device type and code 2332 CALL GPDEVC (4,8) 2333 PLTEXT = 'BMP' 2334 CALL FRQPLG 2335 $ (HEADNG,NPKPLT, PKLOG, SYSPP, WRCPP, WEIBA, 2336 $ NPLOT,SYSRFC,WRCFC,FCXPG,HSTFLG, 2337 $ NOCLIM, CLIML, CLIMU, IPLTNO, PLTEXT ) 2338 IF (IPLTOP.GT.0 .AND. 2339 $ (GRFMT.EQ.'CGM' .OR. GRFMT(1:2).EQ.'PS' .OR. 2340 $ GRFMT.EQ.'WMF')) THEN !generate graphic metafiles also 2341C set device type and code 2342 IF (GRFMT.EQ.'CGM') THEN 2343 CALL GPDEVC (4,4) 2344 ELSE IF (GRFMT(1:2).EQ.'PS') THEN 2345 CALL GPDEVC (4,6) 2346 ELSE IF (GRFMT.EQ.'WMF') THEN 2347 CALL GPDEVC (4,9) 2348 END IF 2349 CALL FRQPLG 2350 $ (HEADNG,NPKPLT, PKLOG, SYSPP, WRCPP, WEIBA, 2351 $ NPLOT,SYSRFC,WRCFC,FCXPG,HSTFLG, Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 75 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 ------------------------------------------------------------- 2352 $ NOCLIM, CLIML, CLIMU, IPLTNO, GRFMT ) 2353 END IF 2354 END IF 2355C 2356 RETURN 2357 END Bytes of stack required for this program unit: 120. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- CLIML (REAL) array 2258s 2272s 2337r 2334r 2334r 2352r 2349r 2349r CLIMU (REAL) array 2258s 2272s 2337r 2334r 2334r 2352r 2349r 2349r DEVCOD (INTEGER) scalar 2297s EPSILN (REAL) scalar 2298s 2309/ 2318u FCXPG (REAL) array 2257s 2272s 2326r 2324r 2324r 2336r 2334r 2334r 2351r 2349r 2349r FRQPLG SUBROUTINE 2305u 2334u 2349u FRQPLT SUBROUTINE 2305u 2324u GPDEVC SUBROUTINE 2306u 2332u 2343u 2345u 2347u GPINIT Procedure 2306u GRFMT (CHARACTER) scalar 2255s 2269s 2339u 2339u 2340u 2342u 2344u 2346u 2352r 2349r 2349r 2338i 2338i 2338i 2342i 2344i 2346i HEADNG (CHARACTER) array 2255s 2270s 2317o 2317o 2335r 2334r 2334r 2350r 2349r 2349r HSTFLG (INTEGER) scalar 2257s 2268s 2336r 2334r 2334r 2351r 2349r 2349r IGKSPL (INTEGER) scalar 2297s 2313= 2329u IPLTNO (INTEGER) scalar 2258s 2268s 2337r 2334r 2334r 2352r 2349r 2349r IPLTOP (INTEGER) scalar 2255s 2267s 2313r 2314u 2338u IPRTPL (INTEGER) scalar 2297s 2314= 2316u IWXMOD (INTEGER) scalar 2257s 2267s 2326r 2324r 2324r MSG (INTEGER) scalar 2255s 2267s 2317o 2319o 2322o 2324r 2324r 2324r NOCLIM (INTEGER) scalar 2258s 2268s 2337r 2334r 2334r 2352r 2349r 2349r NPKPLT (INTEGER) scalar 2256s 2267s 2325r 2324r 2324r 2335r 2334r 2334r 2350r 2349r 2349r NPLOT (INTEGER) scalar 2257s 2267s 2326r 2324r 2324r 2336r 2334r 2334r 2351r 2349r 2349r PKLOG (REAL) array 2256s 2271s 2325r 2324r 2324r 2335r 2334r 2334r 2350r 2349r 2349r PLTEXT (CHARACTER) scalar 2299s 2333= 2337r 2334r 2334r PLTFRQ SUBROUTINE 2254s SYSPP (REAL) array 2256s 2271s 2325r 2324r 2324r 2335r 2334r 2334r 2350r 2349r 2349r SYSRFC (REAL) array 2257s 2271s 2326r 2324r 2324r 2336r 2334r 2334r 2351r 2349r 2349r WEIBA (REAL) scalar 2256s 2272s 2318r 2320o 2335r 2334r 2334r 2350r 2349r 2349r WRCFC (REAL) array 2257s 2271s 2326r 2324r 2324r 2336r 2334r 2334r 2351r 2349r 2349r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 76 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 ------------------------------------------------------------- WRCPP (REAL) array 2256s 2271s 2325r 2324r 2324r 2335r 2334r 2334r 2350r 2349r 2349r Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 77 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE FRQPLT Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2358C 2359C 2360C 2361 SUBROUTINE FRQPLT 2362 # ( MSG , NPKS,PLGSRT,PPOS1,PPOSHW,QSTA, 2363 $ QHW,XPRB,NPLT,IWXMOD) 2364C 2365C + + + PURPOSE + + + 2366C FREQUENCY PLOT OBSERVED AND COMPUTED PEAKS. 2367C REV 12/83 FOR PRIME -- WK. 2368C 6/28 FORCE AT LEAST 1 LOG CYCLE PLOT RANGE 2369C 6/22 CALL J407SC NOT PPPSCL TO GET PRETTY LOG SCALE UNITS 1 OR 5 2370C 6/17 CALL J407P4 INSTEAD OF PLOT4 TO PRINT NATURAL UNITS PEAKS. 2371C 2372C + + + DUMMY ARGUMENTS + + + 2373 INTEGER MSG, NPKS, NPLT, IWXMOD 2374 REAL PLGSRT(*),PPOS1(*),PPOSHW(*), 2375 # XPRB(*),QSTA(*),QHW(*) 2376C 2377C + + + ARGUMENT DEFINITIONS + + + 2378C MSG - 2379C NPKS - 2380C PLGSRT - 2381C PPOS1 - 2382C PPOSHW - 2383C QSTA - 2384C QHW - 2385C XPRB - 2386C NPLT - 2387C IWXMOD - 2388C + + + COMMON BLOCKS + + + 2389C 2390C + + + LOCAL VARIABLES + + + 2391 INTEGER NSCLE(5) 2392 INTEGER IVGRID(13) 2393 CHARACTER*1 PLTSYM(4) 2394 INTEGER NVGRID, JJ, KK, J, I, MM 2395 REAL PLTBAS, PP0, PP1, PQMAX, PQMIN, QMIN, QMNP, 2396 & QMAX 2397C 2398C + + + INTRINSICS + + + 2399 INTRINSIC AMIN1, AMAX1 2400C 2401C + + + FUNCTIONS + + + 2402C 2403C + + + EXTERNALS + + + 2404 EXTERNAL J407P4, PLOT3, PLOT22, PLOT3N, PLOT2, PLOT1 2405 EXTERNAL J407SC, OMIT 2406C 2407C + + + DATA INITIALIZATIONS + + + 2408 DATA PLTBAS/0./, PLTSYM / '*', 'O', '$', '#'/ 2409 DATA NSCLE / 1, 0, 1, 0, 0/ Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 78 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 ------------------------------------------------------------- 2410 DATA IVGRID/6,19,26,35, 41,51,61,67,76,83,91,96,101/ 2411 DATA PP1,PP0/-2.5762,+2.8785/, NVGRID/13/ 2412C 2413C + + + FORMATS + + + 2414 163 FORMAT(/' ',12X,'99.5 99.0',9X,'95.0 90.0 80.0 70.0', 2415 # 6X,'50.0 30.0 20.0 10.0 5.0 2.0 1.0 0.5 ', 2416 # '0.2'/35X,'ANNUAL EXCEEDANCE PROBABILITY, PERCENT ', 2417 $ '(NORMAL SCALE)' ) 2418C 2419C + + + END SPECIFICATIONS + + + 2420C 2421C FIND SMALLEST NONTRIVIAL COMPUTED PCTILES 2422 DO70JJ=1,NPLT 2423 IF(QSTA(JJ).GT.-10.)GOTO71 2424 70 CONTINUE 2425 JJ=NPLT 2426 71 DO75KK=1,NPLT 2427 IF(QHW(KK).GT.-10.)GOTO76 2428 75 CONTINUE 2429 KK=NPLT 2430 76 CONTINUE 2431 QMIN=AMIN1(QSTA(JJ),QHW(KK),PLGSRT(NPKS)) 2432 QMAX=AMAX1(QSTA(NPLT),QHW(NPLT),PLGSRT(1)) 2433 QMNP=AMAX1(QMIN,PLTBAS) 2434C FORCE PLOT RANGE GE 1 LOG CYCLE 2435 IF(QMAX-QMNP.GE.1.)GOTO80 2436 IF(QMAX.LE.8.5)QMAX=QMAX+1. 2437 IF(QMAX.GT.8.5)QMNP=QMNP-1. 2438 80 CONTINUE 2439 CALL J407SC(QMAX,QMNP,5, PQMAX,PQMIN) 2440 IF(QMIN.LT.PQMIN)WRITE(MSG,62) 2441 62 FORMAT(' ***FRQPLT WILL DROP POINTS BELOW PLOT BASE.') 2442C 2443C 2444 CALL PLOT1(NSCLE,5,10,1,106) 2445C NOTE -- DUMMY ARG IS REQUIRED IN ARG LIST BUT NOT USED -- 2446 CALL PLOT2( PP0, PP1, PQMAX , PQMIN) 2447 CALL PLOT22(NVGRID,IVGRID) 2448 J=8 2449 I=5 2450 CALL PLOT3N('***** NOTICE ***** NOTICE ******',I+0,J,36) 2451 IF(IWXMOD.NE.2) 2452 $CALL PLOT3N('* PRELIMINARY MACHINE COMPUTATION. *',I+1,J,36) 2453 IF(IWXMOD.EQ.2) 2454 $CALL PLOT3N('* EXPERIMENTAL NON-17B COMPUTATION.*',I+1,J,36) 2455 CALL PLOT3N('* USER IS RESPONSIBLE FOR ASSESS- *',I+2,J,36) 2456 CALL PLOT3N('* MENT AND INTERPRETATION. *',I+3,J,36) 2457 CALL PLOT3N('************************************',I+4,J,36) 2458 I=12 2459 J=10 2460 CALL PLOT3N(' PLOT SYMBOL KEY ',I+0,J,30) 2461 CALL PLOT3N('_ 17B FINAL FREQUENCY CURVE ',I+1,J,30) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 79 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 ------------------------------------------------------------- 2462 CALL PLOT3N('_ OBSERVED (SYSTEMATIC) PEAKS',I+2,J,30) 2463 CALL PLOT3N('_ HISTORICALLY ADJUSTED PEAKS',I+3,J,30) 2464 CALL PLOT3N('_ SYSTEMATIC-RECORD FREQ CURVE',I+4,J,31) 2465 CALL PLOT3N('WHEN POINTS COINCIDE, ONLY THE',I+5,J,30) 2466 CALL PLOT3N('TOPMOST SYMBOL SHOWS. ',I+6,J,30) 2467 DO 190 MM=1,4 2468 190 CALL PLOT3N(PLTSYM(MM),I+MM,J,1) 2469 CALL PLOT3(PLTSYM(4),XPRB(JJ),QSTA(JJ),NPLT-JJ+1) 2470 CALL PLOT3(PLTSYM(3),PPOSHW,PLGSRT,NPKS) 2471 CALL PLOT3(PLTSYM(2),PPOS1,PLGSRT,NPKS) 2472 CALL PLOT3(PLTSYM(1),XPRB(KK),QHW(KK),NPLT-KK+1) 2473 CALL OMIT(1) 2474 CALL J407P4(41,' ANNUAL PEAK MAGNITUDES /LOG SCALE/') 2475 CALL OMIT(0) 2476 WRITE(MSG,163) 2477 RETURN 2478 END Bytes of stack required for this program unit: 272. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- FRQPLT SUBROUTINE 2361s I (INTEGER) scalar 2394s 2449= 2450u 2452u 2454u 2455u 2456u 2457u 2458= 2460u 2461u 2462u 2463u 2464u 2465u 2466u 2468u IVGRID (INTEGER) array 2392s 2410/ 2447r 2447r 2447r IWXMOD (INTEGER) scalar 2363s 2373s 2451u 2453u J (INTEGER) scalar 2394s 2448= 2450r 2450r 2450r 2452r 2452r 2452r 2454r 2454r 2454r 2455r 2455r 2455r 2456r 2456r 2456r 2457r 2457r 2457r 2459= 2460r 2460r 2460r 2461r 2461r 2461r 2462r 2462r 2462r 2463r 2463r 2463r 2464r 2464r 2464r 2465r 2465r 2465r 2466r 2466r 2466r 2468r 2468r 2468r J407P4 SUBROUTINE 2404u 2474u J407SC SUBROUTINE 2405u 2439u JJ (INTEGER) scalar 2394s 2423u 2425= 2431u 2469u 2469u 2469u KK (INTEGER) scalar 2394s 2427u 2429= 2431u 2472u 2472u 2472u MM (INTEGER) scalar 2394s 2468u 2468u MSG (INTEGER) scalar 2362s 2373s 2440o 2476o NPKS (INTEGER) scalar 2362s 2373s 2431u 2470r 2470r 2470r 2471r 2471r 2471r NPLT (INTEGER) scalar 2363s 2373s 2422u 2425u 2426u 2429u 2432u 2432u 2469u 2472u NSCLE (INTEGER) array 2391s 2409/ 2444r 2444r 2444r NVGRID (INTEGER) scalar 2394s 2411/ 2447r 2447r 2447r OMIT SUBROUTINE 2405u 2473u 2475u PLGSRT (REAL) array 2362s 2374s 2431r 2431r 2432r 2432r 2470r 2470r 2470r 2471r 2471r 2471r PLOT1 SUBROUTINE 2404u 2444u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 80 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 ------------------------------------------------------------- PLOT2 SUBROUTINE 2404u 2446u PLOT22 SUBROUTINE 2404u 2447u PLOT3 SUBROUTINE 2404u 2469u 2470u 2471u 2472u PLOT3N SUBROUTINE 2404u 2450u 2452u 2454u 2455u 2456u 2457u 2460u 2461u 2462u 2463u 2464u 2465u 2466u 2468u PLTBAS (REAL) scalar 2395s 2408/ 2433r 2433r PLTSYM (CHARACTER) array 2393s 2408/ 2468r 2468r 2468r 2469r 2469r 2469r 2470r 2470r 2470r 2471r 2471r 2471r 2472r 2472r 2472r PP0 (REAL) scalar 2395s 2411/ 2446r 2446r 2446r PP1 (REAL) scalar 2395s 2411/ 2446r 2446r 2446r PPOS1 (REAL) array 2362s 2374s 2471r 2471r 2471r PPOSHW (REAL) array 2362s 2374s 2470r 2470r 2470r PQMAX (REAL) scalar 2395s 2439r 2439r 2439r 2446r 2446r 2446r PQMIN (REAL) scalar 2395s 2439r 2439r 2439r 2440u 2446r 2446r 2446r QHW (REAL) array 2363s 2375s 2427u 2431r 2431r 2432r 2432r 2472r 2472r 2472r QMAX (REAL) scalar 2396s 2432= 2435u 2436u 2436u 2436= 2437u 2439r 2439r 2439r QMIN (REAL) scalar 2395s 2431= 2433r 2433r 2440u QMNP (REAL) scalar 2395s 2433= 2435u 2437u 2437= 2439r 2439r 2439r QSTA (REAL) array 2362s 2375s 2423u 2431r 2431r 2432r 2432r 2469r 2469r 2469r XPRB (REAL) array 2363s 2375s 2469r 2469r 2469r 2472r 2472r 2472r -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 70 2422d 2424s 80 2435g 2438s 71 2423g 2426s 62 2440f 2441s 75 2426d 2428s 76 2427g 2430s 190 2467d 2468s 163 2414s 2476f Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 81 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE J407P4 Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2479C 2480C 2481C 2482 SUBROUTINE J407P4 2483 # (NL,LABEL) 2484C 2485C + + + PURPOSE + + + 2486C SPECIAL VERSION OF PRPLOT FOR PGM J407. 76-06-16 WK. 2487C REVISED FOR PRIME 12/83 WK. 2488C 2489C PRINTS NATURAL UNITS ON VERTICAL LOG SCALE OF J407 2490C LOG-PROBABILITY PRINTER PLOT. 2491C ORDINATE PRINT CALCULATION IS SET UP FOR 1 DECIMAL PLACE (F12.1) 2492C 2493C USGS PROG NO B524 - CCD USER SERVICES 2494C PETE SMIDINGER SUMMER 1966 MATH & COMP BR GSFC NASA 2495C REVISION 730604 WKIRBY USGS-WRD ACTIVATE PLTAPE ENTRY AND 2496C REPLACE DSRN = 6 (CONSTANT) BY VARIABLE IJTAPE 2497C REVISION 8/24/78 WK - PUT IJTAPE VARIABLE IN COMMON PRPCOM FOR USE 2498C BY OTHER PRPLOT ROUTINES. 2499C ADDED PLOT3Z ENTRY TO PLOT SYMBOL VECTOR. WK 1/80. 2500C 2501C REV 4/83 WK FOR *** P R I M E *** *** P R I M E *** 2502C REV 4/83 WK - ENTRY PLOT22 INSERTS IRREGULARLY SPACED VERTICAL GRID 2503C LINES SUCH AS FOR PROBABILITY PAPER. 2504C REV 8/83 WK -- RESET KPLOT1 AT 210 TO RESTORE DEFAULT GRID. 2505C REV 12/83 WK -- ENTRY PLOT3N PUTS A NOTE AT SPECIFIED LINE/COLUMN OF 2506C PLOT-IMAGE AREA. 2507C ******************************************************************** 2508C *** 2509C *** NOTE THAT IMAGE AREA NOW IS A L O C A L VARIABLE 2510C *** NOT SUPPLIED BY USER. BUILT-IN MAX PLOT SIZE IS 2511C *** 7381 CHARACTERS, INCLUDING HORIZ AND VERT AXES. 2512C *** THIS IS ENOUGH FOR 61 MAX-LENGTH LINES OF 121 CHARS. 2513C *** 2514C *** FIRST ARG OF PLOT2 ENTRY STILL MUST BE SUPPLIED 2515C *** BY USER, BUT IT MAY BE ANY DUMMY VARIABLE... 2516C *** IT'S IGNORED BY THE SUBROUTINE. 2517C *** 2518C ******************************************************************** 2519C 2520C 2521C + + + DUMMY ARGUMENTS + + + 2522 INTEGER NL, NSCALE(5), NHL, NSBH, NVL, NSBV, NVGD2, 2523 & IVGD2(*), LSW, JLINE, ICOL, N3, ITAPE 2524 REAL XMAX, XMIN, YMAX, YMIN, X(*), Y(*) 2525 CHARACTER*(*) LABEL, CH 2526C 2527C + + + ARGUMENT DEFINITION + + + 2528C NL - 2529C LABEL - 2530C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 82 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 ------------------------------------------------------------- 2531C + + + COMMON BLOCKS + + + 2532 COMMON / PRPCOM / IJTAPE 2533 INTEGER IJTAPE 2534C 2535C **** P R I M E **** REVISION -- SAVE 2536C + + + SAVE + + + 2537Ckmf SAVE 2538C 2539C + + + LOCAL VARIABLES + + + 2540 CHARACTER*1 IMAGE(7381) 2541 REAL ABNOS(26) 2542 CHARACTER*1 NOS(10), VC, HC,NC,BL,HF,HDOT,HCOMMA,WL 2543 CHARACTER*22 FOR1, FOR2, FOR3 2544 REAL TENTO(10) 2545 INTEGER IITAPE, NH, NSH, NV, NSV, 2546 & NSCL, NVP, NDH, NDHP, NDV, NDVP, NIMG, IY, IX, 2547 & NA, NS, NB, I1, I2, J, I3, I, NN, J1, J2, 2548 & J3, ICHINC, ICH, NX, NY 2549 LOGICAL KPLOT1, KPLOT2, KTAPEI, KABSC, KORD, KBOTGL, KPLOT, 2550 & KNHOR 2551 REAL SQRT10, FSY, FSX, YMX, DH, DV, XMIN1, 2552 & YMIN1, DUM1, DUM2, ORDNO, ORDPRT 2553Ckmf add saves for all local variables 2554 SAVE IMAGE, ABNOS, NOS, VC, HC, NC, BL, HF, HDOT, HCOMMA, WL, 2555 $ FOR1, FOR2, FOR3, 2556 $ TENTO, 2557 $ IITAPE, NH, NSH, NV, NSV, 2558 $ NSCL, NVP, NDH, NDHP, NDV, NDVP, NIMG, IY, IX, 2559 $ NA, NS, NB, I1, I2, J, I3, I, NN, J1, J2, 2560 $ J3, ICHINC, ICH, NX, NY, 2561 $ KPLOT1, KPLOT2, KTAPEI, KABSC, KORD, KBOTGL, KPLOT, 2562 $ KNHOR, 2563 $ SQRT10, FSY, FSX, YMX, DH, DV, XMIN1, 2564 $ YMIN1, DUM1, DUM2, ORDNO, ORDPRT 2565C 2566C + + + INTRINSICS + + + 2567 INTRINSIC MOD, MIN0, INT, IABS, FLOAT, ABS 2568C 2569C + + + ENRTY POINTS + + + 2570C PLOT1, PLOT22, PLOT3, PLOT4, FPLOT4, OMIT, PLTAPE, PLOT2, PLOT3N 2571C PLOT3Z 2572C 2573C + + + DATA INITIALIZATIONS + + + 2574 DATA TENTO/1.,10.,100.,1E3,1E4,1E5,1E6,1E7,1E8,1E9/ 2575 DATA SQRT10/3.16/ 2576 DATA NOS /'0','1','2','3','4','5','6','7','8','9'/ 2577 $ ,HC/'-'/,NC/'+'/,BL/' '/ 2578 $ , HF/'F'/,HDOT/'.'/,HCOMMA/','/ 2579 DATA VC/'|'/ 2580 DATA FOR1 / '(1X,A1,F12.?,1X,121A1)' / 2581 DATA FOR2 / '(1X,A1,13X,121A1 ) ' / 2582 DATA FOR3 / '(1H0,F . , F . ) ' / Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 83 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 ------------------------------------------------------------- 2583C 1...5....11...5....21.. 2584C 2585 DATA IITAPE / 96 / 2586 DATA KPLOT1 /. FALSE./, KPLOT2/.FALSE./ , KTAPEI/.FALSE./ 2587 DATA KABSC,KORD,KBOTGL /3*.FALSE./ 2588C 2589C + + + END SPECIFICATIONS + + + 2590C 2591 GO TO 400 2592C 2593 ENTRY PLOT1(NSCALE,NHL,NSBH,NVL,NSBV) 2594 KPLOT1=.TRUE. 2595 KPLOT2=.FALSE. 2596 NH=IABS(NHL) 2597 NSH=IABS(NSBH) 2598 NV=IABS(NVL) 2599 NSV=IABS(NSBV) 2600 NSCL=NSCALE(1) 2601 125 CONTINUE 2602 IF(.NOT.KTAPEI) IJTAPE=IITAPE 2603 KTAPEI=.TRUE. 2604 IF(NH*NSH*NV*NSV.NE.0) GO TO 128 2605 WRITE(IJTAPE, 14 ) 260614 FORMAT(T5,'SOME PLOT1 ARG. ILLEGALLY 0') 2607 KPLOT=.FALSE. 2608 RETURN 2609128 KPLOT=.TRUE. 2610 IF(NV.LE.25) GO TO 126 2611 WRITE(IJTAPE, 12 ) 2612 KPLOT=.FALSE. 261312 FORMAT(T5,'NO. OF VERTICAL LINES >25') 2614 RETURN 2615126 CONTINUE 2616 NVP=NV+1 2617 NDH=NH*NSH 2618 NDHP=NDH+1 2619 NDV=NV*NSV 2620 NDVP=NDV+1 2621 NIMG=(NDHP*NDVP) 2622 IF(NDV.LE.120) GO TO 130 2623 KPLOT=.FALSE. 2624 WRITE(IJTAPE, 11 ) 262511 FORMAT(T5,'WIDTH OF GRAPH >121') 2626 RETURN 2627130 CONTINUE 2628 IF(NDHP*NDVP.LE. 7381 ) GO TO 135 2629 WRITE(IJTAPE, 133) NDHP,NDVP 2630 133 FORMAT(' *** PRPLOT -- GRAPH DIMENSIONS TOO BIG -- ',2I6) 2631 KPLOT = .FALSE. 2632 RETURN 2633 135 CONTINUE 2634 IF(NSCL.EQ.0) GO TO 70 Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 84 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 ------------------------------------------------------------- 2635 FSY=10.**NSCALE(2) 2636 FSX=10.**NSCALE(4) 2637 IY=MIN0(IABS(NSCALE(3)),7)+1 2638 IX=MIN0(IABS(NSCALE(5)),9)+1 2639 GO TO 75 264070 FSY=1. 2641 FSX=1. 2642 IY=4 2643 IX=4 264475 FOR1(12:12)=NOS(IY) 2645 NA=MIN0(IX,NSV)-1 2646 NS=NA-MIN0(NA,120-NDV) 2647 NB=11-NS+NA 2648 I1=NB/10 2649 I2=NB-I1*10 2650 FOR3(7:7)=NOS(I1+1) 2651 FOR3(8:8)=NOS(I2+1) 2652 FOR3(10:10)=NOS(NA+1) 2653 IF(NV.GT.0) GO TO 90 2654 DO 80 J=11,18 265580 FOR3(J:J)=BL 2656 GO TO 100 2657 90 I1=NV/10 2658 I2=NV-I1*10 2659 FOR3(11:11)=HCOMMA 2660 FOR3(12:12)=NOS(I1+1) 2661 FOR3(13:13)=NOS(I2+1) 2662 FOR3(14:14)=HF 2663 I1=NSV/100 2664 I3=NSV-I1*100 2665 I2=I3/10 2666 I3=I3-I2*10 2667 FOR3(15:15)=NOS(I1+1) 2668 FOR3(16:16)=NOS(I2+1) 2669 FOR3(17:17)=NOS(I3+1) 2670 FOR3(18:18)=HDOT 2671 FOR3(19:19)=FOR3(10:10) 2672100 IF(KPLOT1) RETURN 2673 KPLOT1=.TRUE. 2674C 2675 ENTRY PLOT2(XMAX,XMIN,YMAX,YMIN) 2676 KPLOT2=.TRUE. 2677 IF(KPLOT1) GO TO 210 2678 NSCL=0 2679 NH=5 2680 NSH=10 2681 NV=10 2682 NSV=10 2683 GO TO 125 2684210 CONTINUE 2685 KPLOT1 = .FALSE. 2686 IF(.NOT.KPLOT)RETURN Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 85 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 ------------------------------------------------------------- 2687 YMX=YMAX 2688 DH=(YMAX-YMIN)/FLOAT (NDH) 2689 DV=(XMAX-XMIN)/FLOAT(NDV) 2690 DO 220 I=1,NVP 2691220 ABNOS(I)=(XMIN+FLOAT((I-1)*NSV)*DV)*FSX 2692 DO 225 I=1,NIMG 2693225 IMAGE(I)=BL 2694 DO 240 I=1,NDHP 2695 I2=I*NDVP 2696 I1=I2-NDV 2697 KNHOR=MOD(I-1,NSH).NE.0 2698 IF(KNHOR) GO TO 230 2699 DO 228 J=I1,I2 2700228 IMAGE(J)=HC 2701230 CONTINUE 2702 DO 240 J=I1,I2,NSV 2703 IF(KNHOR) THEN 2704 IMAGE(J)=VC 2705 ELSE 2706 IMAGE(J)=NC 2707 END IF 2708240 CONTINUE 2709 XMIN1=XMIN-DV/2. 2710 YMIN1=YMIN-DH/2. 2711 RETURN 2712C 2713 ENTRY PLOT22 (NVGD2, IVGD2) 2714C INSERTS IRREGULARLY SPACED VERTICAL GRID LINES SUCH AS 2715C PROBABILITY PAPER. 2716 IF(KPLOT2) GO TO 265 2717 IF(.NOT.KTAPEI) IJTAPE = IITAPE 2718 KTAPEI = .TRUE. 2719 WRITE(IJTAPE,13) 2720 KPLOT = .FALSE. 2721 RETURN 2722 265 CONTINUE 2723 DO 268 NN = 1,NVGD2 2724 J1 = IVGD2(NN) 2725 J2 = (NDHP-1)*NDVP + J1 2726 J3 = J1 - 1 2727 DO 268 J = J1,J2,NDVP 2728 268 IMAGE(J) = IMAGE(J-J3) 2729 RETURN 2730C 2731C 2732 ENTRY PLOT3N(CH,JLINE,ICOL,N3) 2733 ICHINC = -1 2734 GO TO 300 2735 ENTRY PLOT3(CH,X,Y,N3) 2736 ICHINC=0 2737 GO TO 300 2738 ENTRY PLOT3Z(CH, X, Y, N3) Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 86 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 ------------------------------------------------------------- 2739 ICHINC=1 2740300 IF(KPLOT2) GO TO 312 2741 IF(.NOT.KTAPEI) IJTAPE=IITAPE 2742 KTAPEI=.TRUE. 2743 301 WRITE(IJTAPE, 13 ) 274413 FORMAT(T5,'PLOT2 MUST BE CALLED') 2745312 CONTINUE 2746 IF(.NOT.KPLOT) RETURN 2747 IF(N3.GT.0) GO TO 314 2748 KPLOT=.FALSE. 2749 WRITE(IJTAPE, 15 ) 275015 FORMAT(T5,'PLOT3 ARG2 < 0') 2751 RETURN 2752 314 CONTINUE 2753 IF(ICHINC.LT.0) GO TO 350 2754 ICH = 1 - ICHINC 2755 DO 320 I=1,N3 2756 ICH = ICH + ICHINC 2757 DUM1=(X(I)-XMIN1)/DV 2758 DUM2=(Y(I)-YMIN1)/DH 2759 IF(DUM1.LT.0..OR.DUM2.LT.0.) GO TO 320 2760 IF(DUM1.GE.NDVP.OR.DUM2.GE.NDHP) GO TO 320 2761 NX=1+INT(DUM1) 2762 NY=1+INT(DUM2) 2763 J=(NDHP-NY)*NDVP+NX 2764 IMAGE(J)=CH(ICH:ICH) 2765320 CONTINUE 2766 RETURN 2767350 ICHINC = (JLINE-1)*NDVP + ICOL - 1 2768 DO 355 I = 1,N3 2769 355 IMAGE(ICHINC+I) = CH(I:I) 2770 RETURN 2771C 2772C 2773 400 CONTINUE 2774 ENTRY PLOT4(NL,LABEL) 2775 ENTRY FPLOT4(NL,LABEL) 2776 IF(.NOT.KPLOT) RETURN 2777 IF(.NOT.KPLOT2) GO TO 301 2778 DO 420 I=1,NDHP 2779 IF(I.EQ.NDHP.AND.KBOTGL) GO TO 420 2780 WL=BL 2781 IF(I.LE.NL) WL = LABEL(I:I) 2782 I2=I*NDVP 2783 I1=I2-NDV 2784 IF(MOD(I-1,NSH).EQ.0.AND..NOT.KORD) GO TO 410 2785 WRITE (IJTAPE, FOR2) WL,(IMAGE(J),J=I1,I2) 2786 GO TO 420 2787410 CONTINUE 2788Ckmf added .00001 to YMX because pc rounded float(i-1)*dh to slightly 2789Ckmf larger than YMX (when they should have been equal), causing ordno 2790Ckmf to be incorrectly negative in some cases. Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 87 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 ------------------------------------------------------------- 2791Ckmf ORDNO=(YMX-FLOAT(I-1)*DH)*FSY 2792 ORDNO=(YMX+0.00001 - FLOAT(I-1)*DH) * FSY 2793C *** J407 *** 2794C CVT ORDNO (LOG) TO ROUNDED NATURAL FOR PRINTING 2795Caml changed fron E38 to E29 for 5/94 fortran complier 2796 ORDPRT = 1E29 2797 IF(ORDNO.GE.10. .OR. ORDNO.LT.-1.2) GO TO 419 2798 J = ORDNO + .001 2799 IF(ORDNO .LT. 0.) J = J - 1 2800 ORDPRT = TENTO(IABS(J)+1) 2801 IF(J.LT.0) ORDPRT = 1./ORDPRT 2802 IF(ABS(ORDNO-J).GT.0.1) ORDPRT = ORDPRT*SQRT10 2803 IF(ORDNO.GE.5.3) ORDPRT = ORDPRT + 0.05 2804 419 ORDNO = ORDPRT 2805C WRITE (*,*) "J407P4:IJTAPE:",IJTAPE," ORDNO:",ORDNO, 2806C $ " I1,2:",I1,I2," WL:'",WL,"'" 2807C WRITE (*,*) " FOR1:'",FOR1,"' IMAGE:",(IMAGE(J),J=I1,I2) 2808 WRITE (IJTAPE,FOR1) WL,ORDNO,(IMAGE(J),J=I1,I2) 2809420 CONTINUE 2810C jlk: Removal of the next debug write causes fatal error on lahey 2811C unless compiled with no optimization (-o0) 2812C WRITE (*,*) "J407P4:KABSC:'",KABSC,"' NVP:",NVP 2813C IF (KABSC) GO TO 430 2814 IF (KABSC .EQV. .FALSE.) THEN 2815 WRITE (IJTAPE,FOR3) (ABNOS(J),J=1,NVP) 2816 END IF 2817C430 CONTINUE 2818C WRITE (*,*) "J407P4:PLOT4:Return" 2819 RETURN 2820C 2821 ENTRY OMIT(LSW) 2822 KABSC=MOD(LSW,2).EQ.1 2823 KORD=MOD(LSW,4).GE.2 2824 KBOTGL=LSW.GE.4 2825 RETURN 2826C 2827 ENTRY PLTAPE(ITAPE) 2828 IJTAPE = ITAPE 2829 KTAPEI = .TRUE. 2830 RETURN 2831 END Bytes of stack required for this program unit: 472. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- ABNOS (REAL) array 2541s 2554s 2691= 2815o BL (CHARACTER) scalar 2542s 2554s 2577/ 2655u 2693u 2780u CH (CHARACTER) scalar 2525s 2732s 2735s 2738s 2764u 2769u DH (REAL) scalar 2551s 2563s 2688= 2710u 2758u 2792u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 88 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 ------------------------------------------------------------- DUM1 (REAL) scalar 2552s 2564s 2757= 2759u 2760u 2761r DUM2 (REAL) scalar 2552s 2564s 2758= 2759u 2760u 2762r DV (REAL) scalar 2551s 2563s 2689= 2691u 2709u 2757u FOR1 (CHARACTER) scalar 2543s 2555s 2580/ 2644= 2808i FOR2 (CHARACTER) scalar 2543s 2555s 2581/ 2785i FOR3 (CHARACTER) scalar 2543s 2555s 2582/ 2650= 2651= 2652= 2655= 2659= 2660= 2661= 2662= 2667= 2668= 2669= 2670= 2671= 2671u 2815i FPLOT4 SUBROUTINE 2775s FSX (REAL) scalar 2551s 2563s 2636= 2641= 2691u FSY (REAL) scalar 2551s 2563s 2635= 2640= 2792u HC (CHARACTER) scalar 2542s 2554s 2577/ 2700u HCOMMA (CHARACTER) scalar 2542s 2554s 2578/ 2659u HDOT (CHARACTER) scalar 2542s 2554s 2578/ 2670u HF (CHARACTER) scalar 2542s 2554s 2578/ 2662u I (INTEGER) scalar 2547s 2559s 2691u 2691u 2693u 2695u 2697u 2757u 2758u 2769u 2769u 2769u 2779u 2781u 2781u 2781u 2782u 2784u 2792u I1 (INTEGER) scalar 2547s 2559s 2648= 2649u 2650u 2657= 2658u 2660u 2663= 2664u 2667u 2696= 2699u 2702u 2783= 2785o 2808o I2 (INTEGER) scalar 2547s 2559s 2649= 2651u 2658= 2661u 2665= 2666u 2668u 2695= 2696u 2699u 2702u 2782= 2783u 2785o 2808o I3 (INTEGER) scalar 2547s 2559s 2664= 2665u 2666u 2666= 2669u ICH (INTEGER) scalar 2548s 2560s 2754= 2756u 2756= 2764u 2764u ICHINC (INTEGER) scalar 2548s 2560s 2733= 2736= 2739= 2753u 2754u 2756u 2767= 2769u ICOL (INTEGER) scalar 2523s 2732s 2767u IITAPE (INTEGER) scalar 2545s 2557s 2585/ 2602u 2717u 2741u IJTAPE (INTEGER) scalar 0 2532s 2533s 2602= 2605o 2611o 2624o 2629o 2717= 2719o 2741= 2743o 2749o 2785o 2808o 2815o 2828= IMAGE (CHARACTER) array 2540s 2554s 2693= 2700= 2704= 2706= 2728= 2728u 2764= 2769= 2785o 2785o 2808o 2808o ITAPE (INTEGER) scalar 2523s 2827s 2828u IVGD2 (INTEGER) array 2523s 2713s 2724u IX (INTEGER) scalar 2546s 2558s 2638= 2643= 2645r 2645r IY (INTEGER) scalar 2546s 2558s 2637= 2642= 2644u J (INTEGER) scalar 2547s 2559s 2655u 2655u 2700u 2704u 2706u 2728u 2728u 2763= 2764u 2785= 2785u 2785u 2798= 2799u 2799= 2800r 2801u 2802u 2808= 2808u 2808u 2815= 2815u 2815u J1 (INTEGER) scalar 2547s 2559s 2724= 2725u 2726u 2727u J2 (INTEGER) scalar 2547s 2559s 2725= 2727u J3 (INTEGER) scalar 2548s 2560s 2726= 2728u J407P4 SUBROUTINE 2482s JLINE (INTEGER) scalar 2523s 2732s 2767u KABSC (LOGICAL) scalar 2549s 2561s 2587/ 2814u 2822= KBOTGL (LOGICAL) scalar 2549s 2561s 2587/ 2779u 2824= KNHOR (LOGICAL) scalar 2550s 2562s 2697= 2698u 2703u KORD (LOGICAL) scalar 2549s 2561s 2587/ 2784u 2823= KPLOT (LOGICAL) scalar 2549s 2561s 2607= 2609= 2612= 2623= 2631= 2686u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 89 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 ------------------------------------------------------------- 2720= 2746u 2748= 2776u KPLOT1 (LOGICAL) scalar 2549s 2561s 2586/ 2594= 2672u 2673= 2677u 2685= KPLOT2 (LOGICAL) scalar 2549s 2561s 2586/ 2595= 2676= 2716u 2740u 2777u KTAPEI (LOGICAL) scalar 2549s 2561s 2586/ 2602u 2603= 2717u 2718= 2741u 2742= 2829= LABEL (CHARACTER) scalar 2483s 2525s 2774s 2775s 2781u LSW (INTEGER) scalar 2523s 2821s 2822r 2823r 2824u N3 (INTEGER) scalar 2523s 2732s 2735s 2738s 2747u 2755u 2768u NA (INTEGER) scalar 2547s 2559s 2645= 2646r 2646r 2646u 2647u 2652u NB (INTEGER) scalar 2547s 2559s 2647= 2648u 2649u NC (CHARACTER) scalar 2542s 2554s 2577/ 2706u NDH (INTEGER) scalar 2546s 2558s 2617= 2618u 2688r NDHP (INTEGER) scalar 2546s 2558s 2618= 2621u 2628u 2629o 2694u 2725u 2760u 2763u 2778u 2779u NDV (INTEGER) scalar 2546s 2558s 2619= 2620u 2622u 2646u 2689r 2696u 2783u NDVP (INTEGER) scalar 2546s 2558s 2620= 2621u 2628u 2629o 2695u 2725u 2727u 2760u 2763u 2767u 2782u NH (INTEGER) scalar 2545s 2557s 2596= 2604u 2617u 2679= NHL (INTEGER) scalar 2522s 2593s 2596r NIMG (INTEGER) scalar 2546s 2558s 2621= 2692u NL (INTEGER) scalar 2483s 2522s 2774s 2775s 2781u NN (INTEGER) scalar 2547s 2559s 2724u NOS (CHARACTER) array 2542s 2554s 2576/ 2644u 2650u 2651u 2652u 2660u 2661u 2667u 2668u 2669u NS (INTEGER) scalar 2547s 2559s 2646= 2647u NSBH (INTEGER) scalar 2522s 2593s 2597r NSBV (INTEGER) scalar 2522s 2593s 2599r NSCALE (INTEGER) array 2522s 2593s 2600u 2635u 2636u 2637r 2638r NSCL (INTEGER) scalar 2546s 2558s 2600= 2634u 2678= NSH (INTEGER) scalar 2545s 2557s 2597= 2604u 2617u 2680= 2697r 2784r NSV (INTEGER) scalar 2545s 2557s 2599= 2604u 2619u 2645r 2645r 2663u 2664u 2682= 2691u 2702u NV (INTEGER) scalar 2545s 2557s 2598= 2604u 2610u 2616u 2619u 2653u 2657u 2658u 2681= NVGD2 (INTEGER) scalar 2522s 2713s 2723u NVL (INTEGER) scalar 2522s 2593s 2598r NVP (INTEGER) scalar 2546s 2558s 2616= 2690u 2815o NX (INTEGER) scalar 2548s 2560s 2761= 2763u NY (INTEGER) scalar 2548s 2560s 2762= 2763u OMIT SUBROUTINE 2821s ORDNO (REAL) scalar 2552s 2564s 2792= 2797u 2797u 2798u 2799u 2802u 2803u 2804= 2808o ORDPRT (REAL) scalar 2552s 2564s 2796= 2800= 2801u 2801= 2802u 2802= 2803u 2803= 2804u PLOT1 SUBROUTINE 2593s PLOT2 SUBROUTINE 2675s PLOT22 SUBROUTINE 2713s PLOT3 SUBROUTINE 2735s PLOT3N SUBROUTINE 2732s PLOT3Z SUBROUTINE 2738s PLOT4 SUBROUTINE 2774s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 90 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 ------------------------------------------------------------- PLTAPE SUBROUTINE 2827s SQRT10 (REAL) scalar 2551s 2563s 2575/ 2802u TENTO (REAL) array 2544s 2556s 2574/ 2800u VC (CHARACTER) scalar 2542s 2554s 2579/ 2704u WL (CHARACTER) scalar 2542s 2554s 2780= 2781= 2785o 2785o 2808o 2808o X (REAL) array 2524s 2735s 2738s 2757u XMAX (REAL) scalar 2524s 2675s 2689u XMIN (REAL) scalar 2524s 2675s 2689u 2691u 2709u XMIN1 (REAL) scalar 2551s 2563s 2709= 2757u Y (REAL) array 2524s 2735s 2738s 2758u YMAX (REAL) scalar 2524s 2675s 2687u 2688u YMIN (REAL) scalar 2524s 2675s 2688u 2710u YMIN1 (REAL) scalar 2552s 2564s 2710= 2758u YMX (REAL) scalar 2551s 2563s 2687= 2792u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 70 2634g 2640s 80 2654d 2655s 90 2653g 2657s 11 2624f 2625s 12 2611f 2613s 13 2719f 2743f 2744s 14 2605f 2606s 15 2749f 2750s 75 2639g 2644s 100 2656g 2672s 300 2734g 2737g 2740s 400 2591g 2773s 210 2677g 2684s 410 2784g 2787s 220 2690d 2691s 320 2755d 2759g 2760g 2765s 420 2778d 2779g 2786g 2809s 130 2622g 2627s 230 2698g 2701s 240 2694d 2702d 2708s 350 2753g 2767s 301 2743s 2777g 312 2740g 2745s 133 2629f 2630s 314 2747g 2752s 125 2601s 2683g 225 2692d 2693s 135 2628g 2633s 355 2768d 2769s 265 2716g 2722s 126 2610g 2615s 128 2604g 2609s 228 2699d 2700s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 91 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 ------------------------------------------------------------- 268 2723d 2727d 2728s 419 2797g 2804s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 92 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE J407SC Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2832C 2833C 2834C 2835 SUBROUTINE J407SC 2836 # (XTOP,XBOT,NGRID,GTOP,GBOT) 2837C 2838C + + + PURPOSE + + + 2839C SPECIAL VERSION OF PPPSCL FOR J407 LOG PLOT PRODUCES ONLY 2840C PRETTY SCALE FACTORS OF 1. AND 5. (NOT 2.). WK 760622 2841C WK 9/23/76 ALLOW SCALE FACT 2 WHEN SCALE IS GT 1. 2842C *** REVISED FOR PRIME *** WK 12/83 2843C 2844C + + + DUMMY ARGUMENTS + + + 2845 REAL XTOP, XBOT, GTOP, GBOT 2846 INTEGER NGRID 2847C 2848C + + + ARGUMENT DEFINITIONS + + + 2849C XTOP - 2850C XBOT - 2851C NGRID - 2852C GTOP - 2853C GBOT - 2854C 2855C + + + LOCAL VARIABLES + + + 2856 LOGICAL NOSWIT 2857 INTEGER MSG, M 2858 REAL X, XMX, XMN, U, UGLY, TOL, TEMP, TENTOM, SMALL, SCALE, 2859 & GRANGE, GMX, GMN, FNGRID,EXCESS, BIG 2860C 2861C + + + INTRINSIC + + + 2862 INTRINSIC SIGN, INT, AMIN1, AMAX1,ALOG10, AINT, ABS 2863C 2864C + + + FUNCTIONS + + + 2865 REAL STEP, ZINT, FLOOR, CEIL 2866C 2867C + + + DATA INITIALIZATIONS + + + 2868 DATA TOL /.005/ 2869 DATA MSG/6/ 2870C 2871C + + + END SPECIFICATIONS + + + 2872C 2873C*************************************** 2874C STATEMENT FUNCTIONS 2875 STEP(X) = .5 + SIGN(.5,X) 2876 ZINT(X) = AINT(X) - 1. + STEP(X) 2877 FLOOR(X) = ZINT(X+TOL) 2878 CEIL(X) = ZINT(X+1.-TOL) 2879C*************************************** 2880 XMX=AMAX1(XTOP,XBOT) 2881 XMN=AMIN1(XTOP,XBOT) 2882 NOSWIT=XTOP.GT.XBOT 2883 FNGRID=NGRID Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 93 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 ------------------------------------------------------------- 2884 UGLY=(XMX-XMN)/FNGRID 2885 U=0. 2886 M=0 2887 IF(ABS(UGLY).LE.0.) GO TO 11 2888 U = ALOG10(ABS(UGLY)) 2889 M=INT(U) 2890 IF(U.LT.0.) M = M - 1 2891 U = 10**(U-M) 2892 11 CONTINUE 2893 IF(U.LT.1.+TOL)U=10.*U 2894 TENTOM=UGLY/U 2895 U=U/(1.+TOL) 2896 SCALE=5. 2897 IF(U.LT.2. .AND. UGLY.GT.1.) SCALE=2. 2898 IF(U.GT.5.)SCALE=10. 2899 SCALE=SCALE*TENTOM 2900C 20 CONTINUE 2901 GMX=CEIL(XMX/SCALE) 2902 GMN=FLOOR(XMN/SCALE) 2903 GRANGE=GMX-GMN 2904 IF(GRANGE.LE.FNGRID)GOTO100 2905 IF(ABS((SCALE/TENTOM)-5.) .LT. 1.)GOTO80 2906 GMX=CEIL(2.*XMX/SCALE)/2. 2907 GMN=FLOOR(2.*XMN/SCALE)/2. 2908 GRANGE=GMX-GMN 2909 IF(GRANGE.LE.FNGRID)GOTO100 2910 80 CONTINUE 2911 SCALE=2.*SCALE 2912 IF(SCALE.LT.(5.*TENTOM))SCALE=(5.*TENTOM) 2913 GMX=CEIL(XMX/SCALE) 2914 GMN=FLOOR(XMN/SCALE) 2915 GRANGE=GMX-GMN 2916 IF(GRANGE.LE.FNGRID)GOTO100 2917 WRITE(MSG,98)XTOP,XBOT,GMX,GMN,SCALE 2918 98 FORMAT(/' ***PRPSCL098 LOGIC ERROR',1P5E16.6/) 2919 GBOT=XBOT 2920 GTOP=XTOP 2921 RETURN 2922 100 CONTINUE 2923 EXCESS=FNGRID-GRANGE 2924 SMALL=AINT(EXCESS/2.) 2925 BIG=EXCESS-SMALL 2926 IF((GMX*SCALE-XMX) .GT. (XMN-GMN*SCALE))GOTO110 2927 GMX=GMX+BIG 2928 GMN=GMN-SMALL 2929 GOTO120 2930 110 GMX=GMX+SMALL 2931 GMN=GMN-BIG 2932 120 CONTINUE 2933 GTOP=GMX*SCALE 2934 GBOT=GMN*SCALE 2935 IF(NOSWIT)GOTO130 Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 94 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 ------------------------------------------------------------- 2936 TEMP=GBOT 2937 GBOT=GTOP 2938 GTOP=TEMP 2939 130 CONTINUE 2940 RETURN 2941 END Bytes of stack required for this program unit: 568. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- BIG (REAL) scalar 2859s 2925= 2927u 2931u CEIL FUNCTION 2901u 2906u 2913u CEIL (REAL) scalar 2865s EXCESS (REAL) scalar 2859s 2923= 2924u 2925u FLOOR FUNCTION 2902u 2907u 2914u FLOOR (REAL) scalar 2865s FNGRID (REAL) scalar 2859s 2883= 2884u 2904u 2909u 2916u 2923u GBOT (REAL) scalar 2836s 2845s 2919= 2934= 2936u 2937= GMN (REAL) scalar 2859s 2902= 2903u 2907= 2908u 2914= 2915u 2917o 2926u 2928u 2928= 2931u 2931= 2934u GMX (REAL) scalar 2859s 2901= 2903u 2906= 2908u 2913= 2915u 2917o 2926u 2927u 2927= 2930u 2930= 2933u GRANGE (REAL) scalar 2859s 2903= 2904u 2908= 2909u 2915= 2916u 2923u GTOP (REAL) scalar 2836s 2845s 2920= 2933= 2937u 2938= J407SC SUBROUTINE 2835s M (INTEGER) scalar 2857s 2886= 2889= 2890u 2890= 2891u MSG (INTEGER) scalar 2857s 2869/ 2917o NGRID (INTEGER) scalar 2836s 2846s 2883u NOSWIT (LOGICAL) scalar 2856s 2882= 2935u SCALE (REAL) scalar 2858s 2896= 2897= 2898= 2899u 2899= 2901u 2902u 2905u 2906u 2907u 2911u 2911= 2912u 2912= 2913u 2914u 2917o 2926u 2926u 2933u 2934u SMALL (REAL) scalar 2858s 2924= 2925u 2928u 2930u STEP (REAL) scalar 2865s STEP FUNCTION 2876u TEMP (REAL) scalar 2858s 2936= 2938u TENTOM (REAL) scalar 2858s 2894= 2899u 2905u 2912u 2912u TOL (REAL) scalar 2858s 2868/ 2877u 2878u 2893u 2895u U (REAL) scalar 2858s 2885= 2888= 2889r 2890u 2891u 2891= 2893u 2893u 2893= 2894u 2895u 2895= 2897u 2898u UGLY (REAL) scalar 2858s 2884= 2887r 2888r 2894u 2897u XBOT (REAL) scalar 2836s 2845s 2880r 2880r 2881r 2881r 2882u 2917o 2919u XMN (REAL) scalar 2858s 2881= 2884u 2902u 2907u 2914u 2926u XMX (REAL) scalar 2858s 2880= 2884u 2901u 2906u 2913u 2926u XTOP (REAL) scalar 2836s 2845s 2880r 2880r 2881r 2881r 2882u 2917o 2920u ZINT FUNCTION 2877u 2878u ZINT (REAL) scalar 2865s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 95 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) ------------------------------------------------------------------------------------------------------------------------------- 80 2905g 2910s 11 2887g 2892s 98 2917f 2918s 100 2904g 2909g 2916g 2922s 110 2926g 2930s 120 2929g 2932s 130 2935g 2939s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 96 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE MOVEI Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2942C 2943C 2944C 2945 SUBROUTINE MOVEI 2946 # (ISOURC, IDATA, NITEMS) 2947C 2948C + + + PURPOSE + + + 2949C MOVES INTEGER DATA FROM ISOURC TO IDATA, NITEMS ITEMS. 2950C 2951C + + + DUMMY ARGUMENTS + + + 2952 INTEGER NITEMS 2953 INTEGER ISOURC(NITEMS), IDATA(NITEMS) 2954C 2955C + + + ARGUMENT DEFINITIONS + + + 2956C ISOURC - 2957C IDATA - 2958C NITEMS - 2959C 2960C + + + LOCAL VARIABLES + + + 2961 INTEGER I 2962C 2963C + + + END SPECIFICATIONS + + + 2964C 2965 DO 30 I=1,NITEMS 2966 30 IDATA(I) = ISOURC(I) 2967C 2968 RETURN 2969 END Bytes of stack required for this program unit: 24. -------------------------------------------------- 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 2961s 2966u 2966u IDATA (INTEGER) array 2946s 2953s 2966= ISOURC (INTEGER) array 2946s 2953s 2966u MOVEI SUBROUTINE 2945s NITEMS (INTEGER) scalar 2946s 2952s 2953u 2953u 2965u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 30 2965d 2966s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 97 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE SORTI Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 2970C 2971C 2972C 2973 SUBROUTINE SORTI 2974 # (IDATA, NITEMS) 2975C 2976C + + + PURPOSE + + + 2977C SORTS INTEGER ARRAY IDATA (NITEMS ITEMS). 2978C 2979C + + + DUMMY ARGUMENTS + + + 2980 INTEGER NITEMS 2981 INTEGER IDATA(NITEMS) 2982C 2983C + + + LOCAL VARIABLES + + + 2984 INTEGER I, N1, J, N2, ITEMP 2985C 2986C + + + END SPECIFICATIONS + + + 2987C 2988 N1 = NITEMS-1 2989 DO 40 I = 1,N1 2990 N2 = NITEMS-I 2991 DO 20 J = 1,N2 2992 IF(IDATA(J).LE.IDATA(J+1)) GO TO 20 2993 ITEMP = IDATA(J+1) 2994 IDATA(J+1) = IDATA(J) 2995 IDATA(J) = ITEMP 2996 20 CONTINUE 2997 40 CONTINUE 2998 RETURN 2999 END Bytes of stack required for this program unit: 48. -------------------------------------------------- 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 2984s 2990u IDATA (INTEGER) array 2974s 2981s 2992u 2992u 2993u 2994= 2994u 2995= ITEMP (INTEGER) scalar 2984s 2993= 2995u J (INTEGER) scalar 2984s 2992u 2992u 2993u 2994u 2994u 2995u N1 (INTEGER) scalar 2984s 2988= 2989u N2 (INTEGER) scalar 2984s 2990= 2991u NITEMS (INTEGER) scalar 2974s 2980s 2981u 2988u 2990u SORTI SUBROUTINE 2973s -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 20 2991d 2992g 2996s 40 2989d 2997s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 98 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 ------------------------------------------------------------- Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 99 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE SORTM Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 3000C 3001C 3002C 3003 SUBROUTINE SORTM 3004 # ( W, IW, KENTER, KOPT, NN ) 3005C 3006C + + + PURPOSE + + + 3007C SORTS AN ARRAY IN ASCENDING OR DESCENDING ORDER, 3008C THE ORIGINAL ORDER IS STORED IN IW 3009C 3010C + + + DUMMY ARGUEMENTS + + + 3011 INTEGER KENTER, KOPT, NN 3012 INTEGER IW(NN) 3013 REAL W(NN) 3014C 3015C + + + ARGUMENT DEFINITION + + + 3016C W - ARRAY OF VALUES TO BE SORTED 3017C IW - ARRAY OF ORDER POINTERS FOR W 3018C KENTER - FLAG FOR IW : 0 - IW ALLREADY CONTAINS POINTERS 3019C 1 - IW NEEDS TO BE FILLED 3020C KOPT - SORT OPTION : -1 - DECREASING ORDER 3021C 1 - ASCENDING ORDER 3022C NN - SIZE OF W AND IW ARRAYS 3023C 3024C + + + LOCAL VARIABLES + + + 3025 INTEGER I, J, K, M, N, IT, KASE 3026 REAL T 3027C 3028C + + END SPECIFICATIONS + + + 3029C 3030 N = NN 3031 KASE = 0 3032 IF (KOPT .EQ. -1) KASE = 1 3033 IF (KENTER .EQ. 1) THEN 3034C FILL IW ARRAY 3035 DO 5 I = 1, N 3036 IW(I) = I 3037 5 CONTINUE 3038 END IF 3039 M=N-1 3040 DO30I=1,M 3041 K=N-I 3042 DO20J=1,K 3043 IF(W(J+KASE).LE.W(J+1-KASE))GOTO20 3044 T=W(J) 3045 W(J)=W(J+1) 3046 W(J+1)=T 3047 IT=IW(J) 3048 IW(J)=IW(J+1) 3049 IW(J+1)=IT 3050 20 CONTINUE 3051 30 CONTINUE Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 100 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 ------------------------------------------------------------- 3052 RETURN 3053 END Bytes of stack required for this program unit: 80. -------------------------------------------------- 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 3025s 3036u 3036u 3041u IT (INTEGER) scalar 3025s 3047= 3049u IW (INTEGER) array 3004s 3012s 3036= 3047u 3048= 3048u 3049= J (INTEGER) scalar 3025s 3043u 3043u 3044u 3045u 3045u 3046u 3047u 3048u 3048u 3049u K (INTEGER) scalar 3025s 3041= 3042u KASE (INTEGER) scalar 3025s 3031= 3032= 3043u 3043u KENTER (INTEGER) scalar 3004s 3011s 3033u KOPT (INTEGER) scalar 3004s 3011s 3032u M (INTEGER) scalar 3025s 3039= 3040u N (INTEGER) scalar 3025s 3030= 3035u 3039u 3041u NN (INTEGER) scalar 3004s 3011s 3012u 3013u 3030u SORTM SUBROUTINE 3003s T (REAL) scalar 3026s 3044= 3046u W (REAL) array 3004s 3013s 3043u 3043u 3044u 3045= 3045u 3046= -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 20 3042d 3043g 3050s 30 3040d 3051s 5 3035d 3037s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 101 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. FUNCTION IBITOX Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 3054C 3055C 3056C 3057 INTEGER FUNCTION IBITOX 3058 # (IBIT,N) 3059C 3060C + + + PURPOSE + + + 3061C CONVERTS BIT STRING TO OCTAL-CODED INTEGER. 3062C THE LOW-INDEX (FIRST) 3 WORDS OF IBIT CORRESPOND TO THE LOW- 3063C ORDER OCTAL DIGIT OF THE RESULTANT FUNCTION VALUE. THE FUNCTION 3064C VALUE IS CODED SUCH THAT IF IT IS PRINTED UNDER AN ORDINARY 3065C I FORMAT, THE PRINTED DIGITS WILL BE OCTAL (I.E., 1 2 ... 7). 3066C FOR EXAMPLE, BITS 1 0 1 0 1 0 1 1 1 0 0 0 0 0 1 3067C WOULD YIELD PRINTED VALUE 40725. 3068C WKIRBY 12/87. 3069C 3070C + + + DUMMY ARGUMENTS + + + 3071 INTEGER N 3072 INTEGER IBIT(N) 3073C 3074C + + + ARGUMENT DEFINITIONS + + + 3075C IBIT - INTEGER VECTOR, DIMENSION N, EACH ELEMENT 3076C IS 0 OR 1. (PGM CHECKS THIS, CONVERTS VALUES .LT. 0 TO 0, 3077C VALUES .GT. 1 TO 1.) 3078C N - INTEGER NUMBER OF ELEMENTS IN IBIT. 3079C (MAX N DEPENDS ON INTEGER WORD LENGTH.) 3080C 3081C + + + LOCAL VARIABLES + + + 3082 INTEGER I, MCODE, MBIT, NN, K 3083C 3084C + + + INTRINSICS + + + 3085 INTRINSIC MOD 3086C 3087C + + + END SPECIFICATIONS + + + 3088C 3089 IBITOX = 0 3090 IF(N .LE. 0) RETURN 3091C 3092 MCODE = 0 3093 DO 10 I = 1,N 3094 MBIT = 0 3095 IF(IBIT(I) .GT. 0) MBIT = 1 3096 MCODE = MCODE + MBIT*(2**(I-1)) 3097 10 CONTINUE 3098C 3099 NN = (N+2)/3 3100 DO 20 I = 1,NN 3101 K = MOD(MCODE,8) 3102 IBITOX = IBITOX + K*(10**(I-1)) 3103 MCODE = MCODE/8 3104 20 CONTINUE 3105C Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 102 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 ------------------------------------------------------------- 3106 RETURN 3107C 3108 END Bytes of stack required for this program unit: 24. -------------------------------------------------- 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 3082s 3095u 3096u 3102u IBIT (INTEGER) array 3058s 3072s 3095u IBITOX (INTEGER) scalar 3057s 3089= 3102u 3102= IBITOX FUNCTION 3057s K (INTEGER) scalar 3082s 3101= 3102u MBIT (INTEGER) scalar 3082s 3094= 3095= 3096u MCODE (INTEGER) scalar 3082s 3092= 3096u 3096= 3101r 3103u 3103= N (INTEGER) scalar 3058s 3071s 3072u 3090u 3093u 3099u NN (INTEGER) scalar 3082s 3099= 3100u -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 10 3093d 3097s 20 3100d 3104s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 103 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. FUNCTION IBITEX Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 3109C 3110C 3111C 3112 INTEGER FUNCTION IBITEX 3113 # (ICTAL, N) 3114C 3115C + + + PURPOSE + + + 3116C EXTRACTS BIT NO N OUT OF OCTAL-CODED INTEGER ICTAL 3117C REMARKS -- 3118C THIS FUNCTION IS THE INVERSE OF IBITOX. 3119C 3120C EXAMPLE -- ICTAL = 40725 3121C IBIT = IBITEX(ICTAL, N) 3122C THEN, FOR N = 1 - 15 -- 3123C IBIT = 1 0 1 0 1 0 1 1 1 0 0 0 0 0 1 3124C 3125C WARNING -- IF ICTAL HAS DIGITS 8 OR 9 OR IF IT IS NEGATIVE, 3126C RESULTS ARE UNPREDICTABLE. IBITEX DOES NOT CHECK THIS. 3127C 3128C WK.... 7/88. 3129C 3130C + + + DUMMY ARGUMENTS + + + 3131 INTEGER ICTAL, N 3132C 3133C + + + ARGUMENT DEFINITIONS + + + 3134C ICTAL - INTEGER SCALAR CONSISTING OF OCTAL-CODED DIGITS. 3135C N - INTEGER POSITION OF BIT TO BE EXTRACTED FROM ICTAL, 3136C COUNTING FROM THE RIGHT. (LOW-ORDER BIT = NO 1.) 3137C 3138C + + + LOCAL VARIABLES + + + 3139 INTEGER IOCT, IBIT, IDIGIT 3140C 3141C + + + INTRINSICS + + + 3142 INTRINSIC MOD 3143C 3144C + + + END SPECIFICATIONS + + + 3145C 3146 IDIGIT = (N+2)/3 3147 IOCT = MOD(ICTAL/10**(IDIGIT-1),10) 3148 IBIT = N - 3*(IDIGIT-1) 3149 IBITEX = MOD(IOCT/2**(IBIT-1), 2) 3150 RETURN 3151 END Bytes of stack required for this program unit: 24. -------------------------------------------------- Symbol Cross Reference --------------------------------------------------- Name (Type) Class Offset Context (d-DO, =-Assignment, /-Initialization, i-Input, o-Output, p-Pointer, r-Argument, s-Specification, u-Usage) ------------------------------------------------------------------------------------------------------------------------------- IBIT (INTEGER) scalar 3139s 3148= 3149u IBITEX (INTEGER) scalar 3112s 3149= Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 104 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 ------------------------------------------------------------- IBITEX FUNCTION 3112s ICTAL (INTEGER) scalar 3113s 3131s 3147u IDIGIT (INTEGER) scalar 3139s 3146= 3147u 3148u IOCT (INTEGER) scalar 3139s 3147= 3149u N (INTEGER) scalar 3113s 3131s 3146u 3148u Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 105 Copyright (C) 1994-1998 Lahey Computer Systems. All rights reserved. SUBROUTINE RUNEMA Compiling Options: -chk -ndal -ndbl -nf90 -fix -ng -nhed -nin -inln -lst -pca -stchk -nsyn -trap -nvax -w -nwo -xref ------------------------------------------------ Source Listing ------------------------------------------------------------- 3152C 3153C 3154C 3155Ckmf SUBROUTINE DATTIM 3156Ckmf # ( JDATE, JTIME ) 3157C 3158C + + + PURPOSE + + + 3159C This routine 3160C 3161C + + + HISTORY + + + 3162C kmf - Nov 09, 2000 - replaced by libanne routine 3163C 3164C + + + DUMMY ARGUMENTS + + + 3165Ckmf INTEGER JDATE(3), JTIME 3166C 3167C + + + ARGUMENT DEFINITIONS + + + 3168C JDATE - 3169C JTIME - 3170C 3171C + + + LOCAL VARIABLES + + + 3172Ckmf INTEGER *2 STRING(28) 3173C INTEGER NUM 3174Ckmf CHARACTER*6 IMAGE 3175Ckmf INTEGER J 3176C 3177C + + + INTRINSICS + + + 3178Ckmf INTRINSIC MOD 3179C 3180C + + + EXTERNALS + + + 3181Cmyg EXTERNAL TIMDAT 3182C 3183C + + + DATA INITIALIZATIONS + + + 3184C DATA NUM / 28 / 3185Ckmf DATA STRING / 28*0/ 3186C 3187C + + + END SPECIFICATIONS + + + 3188C 3189Cmyg CALL TIMDAT( STRING, NUM ) 3190Ckmf WRITE(IMAGE,1) ( STRING(J), J = 1, 3 ) 3191Ckmf READ(IMAGE,2) ( JDATE(J), J = 1, 3 ) 3192Ckmf JTIME = ( STRING(4) / 60 ) * 100 + MOD( STRING(4), 60 ) 3193Ckmf1 FORMAT( 3A2 ) 3194Ckmf2 FORMAT( 3I2 ) 3195Ckmf RETURN 3196Ckmf END 3197C 3198C 3199C 3200Cprh SUBROUTINE OUTPT2 3201Cprh I ( STAID, WRCUAV, WRCUSD, WRCSKW, WRCFC, 3202Cprh I MESSFL ) 3203CprhC Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 106 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 ------------------------------------------------------------- 3204CprhC + + + PURPOSE + + + 3205CprhC Send summary of computed statistics to screen for ascii input. 3206Cprh 3207CprhC + + + DUMMY ARGUMENTS + + + 3208Cprh INTEGER MESSFL 3209Cprh REAL WRCUAV, WRCUSD, WRCSKW, WRCFC(*) 3210Cprh CHARACTER*90 STAID 3211Cprh 3212CprhC + + + ARGUMENT DEFINITIONS + + + 3213CprhC STAID - station identification number 3214CprhC WRCUAV - WRC mean of peaks 3215CprhC WRCUSD - WRC standard deviation of peaks 3216CprhC WRCSKW - WRC skew of peaks 3217CprhC WRCFC - array of logs of computed peaks 3218CprhC 3219CprhC + + + LOCAL VARIABLES + + + 3220Cprh INTEGER I, J, ORD(9), TXTL(14), TXTFLG, 3221Cprh $ GROUP, SCLU, LEN, RTCMND 3222Cprh REAL PEAKST(12) 3223Cprh CHARACTER*1 BLNK, FLAG 3224Cprh CHARACTER*71 TXT 3225CprhC 3226CprhC + + + INTRINSICS + + + 3227Cprh INTRINSIC ABS 3228CprhC 3229CprhC + + + EXTERNALS + + + 3230Cprh EXTERNAL ZIPI, ZIPC, CVARAR, LFTSTR 3231Cprh EXTERNAL Q1INIT, QSETCT, QSETR, Q1EDIT 3232CprhC 3233CprhC + + + DATA INITIALIZATIONS + + + 3234CprhC return period 1.25 2 5 10 25 50 100 200 500 3235Cprh DATA ORD / 12, 16, 20, 21, 23, 25, 26, 27, 28 / 3236Cprh DATA BLNK, FLAG, TXTL, SCLU 3237Cprh $ / ' ', '*', 15,12*1,45, 121 / 3238CprhC 3239CprhC + + + END SPECIFICATIONS + + + 3240CprhC 3241Cprh TXTFLG = 0 3242Cprh I = 71 3243Cprh CALL ZIPC ( I, BLNK, TXT ) 3244CprhC 3245CprhC compute t-year peaks 3246Cprh DO 100 I = 1, 9 3247Cprh J = ORD(I) 3248Cprh IF (ABS( WRCFC(J) ) .LT. 20.0) THEN 3249Cprh PEAKST(I) = 10.0**WRCFC(J) 3250Cprh ELSE 3251CprhC magnitude of the exponent is too large 3252Cprh PEAKST(I) = -999. 3253Cprh TXT(I+15:I+15) = FLAG 3254Cprh TXTFLG = 1 3255Cprh END IF Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 107 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 ------------------------------------------------------------- 3256Cprh 100 CONTINUE 3257CprhC 3258CprhC bulletin 17b mean, sd, and skew of log of Q 3259Cprh PEAKST(10) = WRCUAV 3260Cprh PEAKST(11) = WRCUSD 3261Cprh PEAKST(12) = WRCSKW 3262CprhC 3263CprhC station number 3264Cprh TXT(1:15) = STAID(1:15) 3265CprhC 3266Cprh IF (TXTFLG .EQ. 1) THEN 3267CprhC problem with one of more of the statistics, include warning 3268Cprh TXT(28:71) = 'WARNING: problem with flagged (*) attributes' 3269Cprh END IF 3270CprhC 3271CprhC bulletin 17B estimates to screen 3272Cprh GROUP = 55 3273Cprh CALL Q1INIT ( MESSFL, SCLU, GROUP ) 3274Cprh LEN = 12 3275Cprh CALL QSETR ( LEN, PEAKST ) 3276Cprh I = 14 3277Cprh LEN = 71 3278Cprh CALL QSETCT ( I, TXTL, LEN, TXT ) 3279Cprh CALL Q1EDIT ( RTCMND ) 3280CprhC 3281Cprh RETURN 3282Cprh END 3283C 3284C 3285C 3286Cprh SUBROUTINE QEXTRA 3287Cprh I ( XYEAR, 3288Cprh O PEAK ) 3289CprhC 3290CprhC + + + PURPOSE + + + 3291CprhC For the specified recurrence interval, calculate the 3292CprhC corresponding peak. 3293CprhC 3294CprhC + + + DUMMY ARGUMENTS + + + 3295Cprh REAL XYEAR, PEAK 3296CprhC 3297CprhC + + + ARGUMENT DEFINTIONS + + + 3298CprhC XYEAR - recurrence interval, in years 3299CprhC PEAK - flood peak corresponding to XYEAR recurrence 3300CprhC 3301CprhC + + + PARAMETERS + + + 3302Cprh INCLUDE 'pmxint.inc' 3303CprhC 3304CprhC + + + COMMON BLOCKS + + + 3305Cprh INCLUDE 'cwcf1.inc' 3306CprhC 3307CprhC + + + LOCAL VARIABLES + + + Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 108 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 ------------------------------------------------------------- 3308Cprh REAL Q, QBAS 3309CprhC 3310CprhC + + + FUNCTIONS + + + 3311Cprh REAL HARTK 3312CprhC 3313CprhC + + + EXTERNALS + + + 3314Cprh EXTERNAL HARTIV, HARTK 3315CprhC 3316CprhC + + + END SPECIFICATIONS + + + 3317CprhC 3318Cprh CALL HARTIV ( WRCSKW, WORK ) 3319Cprh Q = WRCUAV + WRCUSD * HARTK ( (1.-1./XYEAR), WORK ) 3320Cprh QBAS = WRCUAV + WRCUSD * HARTK ( 1.-WRCPAB, WORK ) 3321CprhC 3322Cprh IF (Q .LT. QBAS ) THEN 3323Cprh PEAK = -999. 3324Cprh ELSE 3325Cprh PEAK = 10**Q 3326Cprh END IF 3327CprhC 3328Cprh RETURN 3329Cprh END 3330C 3331C 3332C 3333 SUBROUTINE RUNEMA 3334 I (NPKS,PKS) 3335C 3336C + + + HISTORY + + + 3337C Created 11/2003 by Paul Hummel, AQUA TERRA Consultants 3338C for incorporating EMA into PEAKFQ 3339C 3340C + + + PURPOSE + + + 3341C Transfers PEAKFQ input data to arguments used in EMA, 3342C runs EMA, transfers EMA results to PEAKFQ output 3343C 3344C + + + DUMMY ARGUMENTS + + + 3345 INTEGER NPKS 3346 REAL PKS(NPKS) 3347C 3348C + + + ARGUMENT DEFINITIONS + + + 3349C NPKS - number of peaks 3350C PKS - array of annual peak values 3351C 3352C + + + PARAMETERS + + + 3353 INCLUDE 'PMXPK.INC' 3354 INCLUDE 'PMXINT.INC' 3355C 3356C + + + COMMON BLOCKS + + + 3357 INCLUDE 'cwcf0.inc' 3358 INCLUDE 'cwcf1.inc' 3359 INCLUDE 'cwcf2.inc' Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 109 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 ------------------------------------------------------------- 3360C 3361C + + + LOCAL VARIABLES + + + 3362 INTEGER I,N 3363 DOUBLE PRECISION QL(MXPK),QU(MXPK),TL(MXPK),TU(MXPK), 3364 $ SYSMOM(3),WRCMOM(3),PR(MXINT), !SKWWGT, | WARNING -- REAL(kind 8) array (SYSMOM) is never used. 3365 $ REGSKEW,REGMSE,SYSYP(MXINT),WRCYP, | WARNING -- REAL(kind 8) array (SYSYP) is never used. 3366 $ CILOW,CIHIGH,THRESH 3367C 3368C + + + EXTERNALS + + + 3369 EXTERNAL EMADATA, EMAFIT 3370C 3371C + + + INTRINSICS + + + 3372 INTRINSIC LOG, LOG10, EXP, DBLE 3373C 3374C + + + END SPECIFICATIONS + + + 3375C 3376 write(*,*) 'RUNEMA: NPKS,NSYS,NHIST ', 3377 $ NPKS,NSYS,NHIST 3378 write(*,*) 'RUNEMA: PKS',(PKS(I),I=1,NPKS) 3379 THRESH = 10**WRCHHB 3380 CALL EMADATA(NPKS-NHIST,PKS(NHIST+1),INT(HISTPD+.5), 3381 I NHIST,PKS,THRESH, 3382 O N,QL,QU,TL,TU) 3383 write(*,*) 'RUNEMA: N,QL',N,(QL(I),I=1,N) 3384C N = 0 3385C DO 10 I = 1,NPKS 3386C IF (PKS(I).GE.0.0) THEN ! valid peak 3387C N = N + 1 3388C IF (PKS(I).GT.0.0001) THEN ! non-zero value 3389C QL(N) = LOG(PKS(I)) 3390C ELSE !mimic original PEAKFQ data processing 3391C QL(N) = -(BIGLOG+.001) 3392C END IF 3393C QU(N) = QL(N) 3394C TL(N) = -9.0D99 3395C TU(N) = 9.0D99 3396C END IF 3397C 10 CONTINUE 3398C 3399 REGSKEW= GENSKU 3400 REGMSE = RMSEGS**2 3401c SKWWGT = GSKWGT 3402 write(*,*) 'calling EMAFIT: N ',N 3403c write(*,*) ' ql ',ql 3404c write(*,*) ' qu ',qu 3405c write(*,*) ' tl ',tl Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 110 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 ------------------------------------------------------------- 3406c write(*,*) ' tu ',tu 3407c write(*,*) ' REGSKEW ',REGSKEW 3408c write(*,*) ' regmse ',REGMSE 3409 3410 IF (N.GT.0) THEN !perform EMA 3411 DO 20 I = 1,MXINT 3412 PR(I)= 1.0 - DBLE(TXPROB(I)) 3413 CALL EMAFIT (N,QL,QU,TL,TU,REGSKEW,REGMSE,PR(I), 3414 O WRCMOM,WRCYP,CILOW,CIHIGH) 3415c if (i.eq.1) then 3416c write(*,*) ' SYS Moments ',sysmom 3417c write(*,*) ' WRC Moments ',wrcmom 3418c end if 3419c write(*,'(f8.4,4f12.3)')txprob(i),exp(SYSYP),exp(WRCYP), 3420c $ exp(CILOW),exp(CIHIGH) 3421c SYSRFC(I)= LOG10(EXP(SYSYP)) 3422 WRCFC(I) = LOG10(EXP(WRCYP)) 3423 CLIML(I) = LOG10(EXP(CILOW)) 3424 CLIMU(I) = LOG10(EXP(CIHIGH)) 3425 20 CONTINUE 3426c store EMA moments in WRC variables 3427 WRCUAV = LOG10(EXP(WRCMOM(1))) 3428 WRCUSD = LOG10(EXP(SQRT(WRCMOM(2)))) 3429 WRCSKW = WRCMOM(3) 3430 3431 3432Cprh This call to EMAFIT was an attempt to do all intervals 3433Cprh within EMAFIT and pass whole arrays back and forth. 3434Cprh This would be more efficient, but never got it quite working. 3435c CALL EMAFIT (N,QL,QU,TL,TU,REGSKEW,REGMSE,MXINT,PR, 3436c O SYSMOM,WRCMOM,SYSYP,WRCYP,CILOW,CIHIGH) 3437C write(*,*)'EMAFIT RESULTS' 3438C write(*,*)' SYSMOM ',SYSMOM 3439C write(*,*)' WRCMOM ',WRCMOM 3440c SYSUAV = LOG10(EXP(SYSMOM(1))) 3441c SYSUSD = LOG10(EXP(SQRT(SYSMOM(2)))) 3442c SYSSKW = SYSMOM(3) 3443c WRCUAV = LOG10(EXP(WRCMOM(1))) 3444c WRCUSD = LOG10(EXP(SQRT(WRCMOM(2)))) 3445c WRCSKW = WRCMOM(3) 3446c DO 30 I = 1,MXINT 3447c SYSRFC(I)= LOG10(EXP(SYSYP(I))) 3448c WRCFC(I) = LOG10(EXP(WRCYP(I))) 3449c CLIML(I) = LOG10(EXP(CILOW(I))) 3450c CLIMU(I) = LOG10(EXP(CIHIGH(I))) 3451c write(*,'(f8.4,4f12.3)')txprob(i),exp(wrcfc(i)),exp(sysrfc(i)), 3452c $ exp(climl(i)),exp(climu(i)) 3453c 30 CONTINUE 3454 END IF 3455C 3456 RETURN 3457 END Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 111 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 ------------------------------------------------------------- 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) ------------------------------------------------------------------------------------------------------------------------------- BIGLOG (REAL) scalar 316 (I2)4s (I2)12s CIHIGH (REAL(kind 8)) scalar 3366s 3414r 3413r 3413r 3424r CILOW (REAL(kind 8)) scalar 3366s 3414r 3413r 3413r 3423r CLIML (REAL) array 256 (I3)2s (I3)4s 3423= CLIMU (REAL) array 384 (I3)3s (I3)5s 3424= CLSIZE (REAL) scalar 40 (I2)3s (I2)11s CPAMP1 (REAL) scalar 344 (I2)6s (I2)14s CPAMP2 (REAL) scalar 348 (I2)6s (I2)14s CPAMP3 (REAL) scalar 352 (I2)6s (I2)14s EMADATA SUBROUTINE 3369u 3380u 3380u EMAFIT SUBROUTINE 3369u 3413u EPFC (REAL) array 128 (I3)2s (I3)4s EPS1 (REAL) scalar 320 (I2)5s (I2)13s EPS2 (REAL) scalar 324 (I2)5s (I2)13s GAGEB (REAL) scalar 12 (I4)2s (I4)10s GENSKU (REAL) scalar 0 (I4)2s (I4)10s 3399u GSKWGT (REAL) scalar 108 (I4)6s (I4)10s GSMAX (REAL) scalar 32 (I2)3s (I2)11s GSMIN (REAL) scalar 28 (I2)3s (I2)11s HISTPD (REAL) scalar 28 (I4)3s (I4)10s 3380u HISTPN (REAL) scalar 100 (I4)6s (I4)10s HISTWT (REAL) scalar 104 (I4)6s (I4)10s HRECWO (REAL) scalar 328 (I2)5s (I2)13s HRECWS (REAL) scalar 336 (I2)5s (I2)13s HRECWX (REAL) scalar 332 (I2)5s (I2)13s I (INTEGER) scalar 3362s 3378= 3378u 3378u 3383= 3383u 3383u 3412u 3412u 3413u 3422u 3423u 3424u IGSOPT (INTEGER) scalar 4 (I4)2s (I4)9s INDX1 (INTEGER) scalar 44 (I2)4s (I2)9s INDX2 (INTEGER) scalar 48 (I2)4s (I2)9s INDXPT (INTEGER) array 56 (I2)4s (I2)9s IWXMOD (INTEGER) scalar 372 (I2)7s (I2)10s MSG (INTEGER) scalar 0 (I2)2s (I2)8s MSL (INTEGER) scalar 4 (I2)2s (I2)8s MXINT (INTEGER) scalar (I1)1s (I1)2s (I2)9u (I2)12u (I4)12u (I3)4u (I3)4u (I3)4u (I3)5u (I3)5u 3364u 3365u 3411u MXPK (INTEGER) scalar (I2)1s (I2)2s 3363u 3363u 3363u 3363u N (INTEGER) scalar 3362s 3382r 3383o 3383o 3402o 3410u 3413r 3413r 3413r 3380r 3380r NBGB (INTEGER) scalar 84 (I4)5s (I4)9s NHIOUT (INTEGER) scalar 92 (I4)5s (I4)9s NHIST (INTEGER) scalar 24 (I4)2s (I4)9s 3377o 3380u 3380u 3381r 3380r 3380r NHISTN (INTEGER) scalar 96 (I4)5s (I4)9s NINDX (INTEGER) scalar 52 (I2)4s (I2)9s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 112 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 ------------------------------------------------------------- NLWOUT (INTEGER) scalar 88 (I4)5s (I4)9s NMISS (INTEGER) scalar 76 (I4)5s (I4)9s NOCLIM (INTEGER) scalar 24 (I2)2s (I2)8s NOEPFC (INTEGER) scalar 20 (I2)2s (I2)8s NOPPOS (INTEGER) scalar 8 (I2)2s (I2)8s NOSYS (INTEGER) scalar 16 (I2)2s (I2)8s NOTRAN (INTEGER) scalar 12 (I2)2s (I2)8s NPKS (INTEGER) scalar 3334s 3345s 3346u 3377o 3378o 3380u NSYS (INTEGER) scalar 80 (I4)5s (I4)9s 3377o PKS (REAL) array 3334s 3346s 3378o 3380r 3381r 3380r 3380r 3380r 3380r PR (REAL(kind 8)) array 3364s 3412= 3413r 3413r 3413r QHIOUT (REAL) scalar 20 (I4)2s (I4)11s QL (REAL(kind 8)) array 3363s 3382r 3383o 3413r 3413r 3413r 3380r 3380r QLWOUT (REAL) scalar 16 (I4)2s (I4)11s QU (REAL(kind 8)) array 3363s 3382r 3413r 3413r 3413r 3380r 3380r REGMSE (REAL(kind 8)) scalar 3365s 3400= 3413r 3413r 3413r REGSKEW (REAL(kind 8)) scalar 3365s 3399= 3413r 3413r 3413r RMSDGS (REAL) scalar 340 (I2)6s (I2)14s RMSEGS (REAL) scalar 8 (I4)2s (I4)10s 3400u RUNEMA SUBROUTINE 3333s SIGHOT (REAL) scalar 360 (I2)7s (I2)15s SIGLOT (REAL) scalar 356 (I2)7s (I2)15s SUMH (REAL(kind 8)) array 176 (I4)8s (I4)15s SUMS (REAL(kind 8)) array 152 (I4)8s (I4)15s SYSAAV (REAL) scalar 132 (I4)7s (I4)11s SYSASD (REAL) scalar 136 (I4)7s (I4)11s SYSASK (REAL) scalar 140 (I4)7s (I4)11s SYSBAS (REAL) scalar 112 (I4)6s (I4)11s SYSMAX (REAL) scalar 148 (I4)8s (I4)11s SYSMIN (REAL) scalar 144 (I4)8s (I4)12s SYSMOM (REAL(kind 8)) array 3364s SYSPAB (REAL) scalar 116 (I4)6s (I4)12s SYSRFC (REAL) array 512 (I3)3s (I3)5s SYSSKW (REAL) scalar 128 (I4)7s (I4)12s SYSUAV (REAL) scalar 120 (I4)6s (I4)12s SYSUSD (REAL) scalar 124 (I4)7s (I4)12s SYSYP (REAL(kind 8)) array 3365s THRESH (REAL(kind 8)) scalar 3366s 3379= 3381r 3380r 3380r TL (REAL(kind 8)) array 3363s 3382r 3413r 3413r 3413r 3380r 3380r TU (REAL(kind 8)) array 3363s 3382r 3413r 3413r 3413r 3380r 3380r TXPROB (REAL) array 184 (I2)4s (I2)12s 3412r WCXAUX (REAL) array 364 (I2)7s (I2)15s WEIBA (REAL) scalar 36 (I2)3s (I2)11s WORK (REAL) array 200 (I4)8s (I4)12s WRCAAV (REAL) scalar 52 (I4)4s (I4)13s WRCASD (REAL) scalar 56 (I4)4s (I4)13s WRCASK (REAL) scalar 60 (I4)4s (I4)13s Lahey Fortran 90 Compiler Release 4.50b Tue Dec 07 16:12:18 2004 Page: 113 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 ------------------------------------------------------------- WRCBAS (REAL) scalar 32 (I4)3s (I4)13s WRCFC (REAL) array 0 (I3)2s (I3)4s 3422= WRCHHB (REAL) scalar 64 (I4)4s (I4)13s 3379u WRCHOT (REAL) scalar 68 (I4)4s (I4)13s WRCLOW (REAL) scalar 72 (I4)5s (I4)13s WRCMOM (REAL(kind 8)) array 3364s 3414r 3413r 3413r 3427r 3428r 3429u WRCPAB (REAL) scalar 36 (I4)3s (I4)14s WRCSKW (REAL) scalar 48 (I4)4s (I4)14s 3429= WRCUAV (REAL) scalar 40 (I4)3s (I4)14s 3427= WRCUSD (REAL) scalar 44 (I4)4s (I4)14s 3428= WRCYP (REAL(kind 8)) scalar 3365s 3414r 3413r 3413r 3422r WSKLAT (REAL) scalar 312 (I2)4s (I2)12s -------------------------------------------------- Label Cross Reference ---------------------------------------------------- Label Context (d-DO, =-ASSIGN, f-FORMAT, g-GOTO, i-IF statement, s-Specification, r-Argument) ------------------------------------------------------------------------------------------------------------------------------- 20 3411d 3425s