[84] | 1 | |
---|
| 2 | PROGRAM DATAEX |
---|
| 3 | C |
---|
| 4 | C Fortran 77 program to read and check format of exchange data files. |
---|
| 5 | C This is mainly a format checking program, but it can also be used to |
---|
| 6 | C retrieve the contents of an exchange file. This is a memory- |
---|
| 7 | C economizer version so for 3-D and 4-D data files (eg. FFI=3010,4010) |
---|
| 8 | C the contents of the primary variable data records are written to an |
---|
| 9 | C unformatted scratch file which is rewound and can be read in this or |
---|
| 10 | C a user-supplied routine. |
---|
| 11 | C |
---|
| 12 | C MS DOS Fortran users will have to break this code into smaller modules |
---|
| 13 | C for compilation. |
---|
| 14 | C |
---|
| 15 | C Sections of code preceded by a string of plus signs (+++) and |
---|
| 16 | C terminated by a string of minus signs (---) indicate locations where |
---|
| 17 | C a user of this program must supply the indicated variable definitions. |
---|
| 18 | C With the possible exception of the OPEN statements, this code is |
---|
| 19 | C standard Fortran 77. |
---|
| 20 | C |
---|
| 21 | C This code is intended to be used with reference to the document |
---|
| 22 | C written by S.Gaines and S.Hipskind entitled "Format Specification |
---|
| 23 | C for Data Exchange". Most of the variables used in this code |
---|
| 24 | C correspond in name and function to those defined in the referenced |
---|
| 25 | C document. |
---|
| 26 | C |
---|
| 27 | C There are three types of error diagnostics written to unit IOU. |
---|
| 28 | C The severity of the error is indicated by the number of asterisks |
---|
| 29 | C preceding the diagnostic. |
---|
| 30 | C |
---|
| 31 | C One asterisk (*) indicates a suggestion for improving the file |
---|
| 32 | C format and the associated "error" will not cause this program to |
---|
| 33 | C reject the file format. |
---|
| 34 | C |
---|
| 35 | C Two asterisks (**) indicate a violation of the format standards but |
---|
| 36 | C the associated error is not fatal, so this program will continue |
---|
| 37 | C after encountering an error of this type. |
---|
| 38 | C |
---|
| 39 | C Three asterisks (***) indicate a fatal error for this program and |
---|
| 40 | C a violation of the format standards (subsequent error diagnostics |
---|
| 41 | C may be meaningless). This type of error can indicate that |
---|
| 42 | C parameter values defined in the PARAMETER statements must be |
---|
| 43 | C redefined. |
---|
| 44 | C |
---|
| 45 | C NOTE: There is one aspect of the file format that may not be checked |
---|
| 46 | C by this routine. That is a ^Z (control-Z, ASCII decimal value |
---|
| 47 | C 26) as the only character in a line. Fortran on some operating |
---|
| 48 | C systems (VMS for example) interprets such an occurence of ^Z as |
---|
| 49 | C an EOF (end-of-file mark) so if one is encountered then this |
---|
| 50 | C program thinks its at the end of the data file and will not |
---|
| 51 | C read beyond it. |
---|
| 52 | C |
---|
| 53 | C In that case, an external process (DCL command file, etc.) may |
---|
| 54 | C have to be used to check the file for occurrences of ^Z and |
---|
| 55 | C write the results of the search to a file defined by the |
---|
| 56 | C character string FCTLZ. This program reads that file (unit |
---|
| 57 | C IZU), if CHCKNP=.TRUE., and notes the line numbers of lines |
---|
| 58 | C containing one or more ^Zs in the output file (IOU). |
---|
| 59 | C |
---|
| 60 | C If FCTLZ does not exist, then this program does not try |
---|
| 61 | C to read unit IZU. |
---|
| 62 | C |
---|
| 63 | C |
---|
| 64 | C BUGS |
---|
| 65 | C |
---|
| 66 | C Note added 91-10-22: These bugs only apply if PARSIT = .FALSE. |
---|
| 67 | C |
---|
| 68 | C General: |
---|
| 69 | C This code reads numeric data values with "free format" read |
---|
| 70 | C statements and assumes that successive numeric values are |
---|
| 71 | C delimited by one or more spaces. Most versions of Fortran also |
---|
| 72 | C permit a comma to be used as a delimiter and some versions may |
---|
| 73 | C allow other characters as delimiters. If these delimiter |
---|
| 74 | C characters (other than spaces) appear in a numeric data record, |
---|
| 75 | C they will not produce a read error, and may go undetected unless |
---|
| 76 | C their presence produces a noticable error in the values of the |
---|
| 77 | C independent variables. |
---|
| 78 | C |
---|
| 79 | C The "free format" Fortran reads may also allow data record format |
---|
| 80 | C errors to go undetected if DX for the independent variable mark is |
---|
| 81 | C zero (nonuniform increment). |
---|
| 82 | C |
---|
| 83 | C FFI 1001: |
---|
| 84 | C If DX(1)=0 and one or more primary variable values are omitted |
---|
| 85 | C from one or more data records, then no format errors will be |
---|
| 86 | C detected. This is an unavoidable bug resulting from the fact |
---|
| 87 | C that the independent and primary variables are read as one |
---|
| 88 | C logical record with no constraints on the number of lines |
---|
| 89 | C occupied by the record. |
---|
| 90 | C |
---|
| 91 | C |
---|
| 92 | C History: |
---|
| 93 | C 06-07-18 (JDW) |
---|
| 94 | C Removed checking for improper mission name |
---|
| 95 | C 06-06-28 (JDW) |
---|
| 96 | C Increased MAXA to 65. |
---|
| 97 | C Increased MAXCA to 25. |
---|
| 98 | C 06-06-22 (JDW) |
---|
| 99 | C Increased MAXAC from 10 to 15 |
---|
| 100 | C |
---|
| 101 | C 96-02-29 (JDW) |
---|
| 102 | C Increased MAXA from 30 to 40. |
---|
| 103 | C |
---|
| 104 | C 96-02-29 (JDW) |
---|
| 105 | C Modified RHEAD to skip over database header if DBHEAD = .TRUE. |
---|
| 106 | C Modified DATAEX to set DBHEAD |
---|
| 107 | C |
---|
| 108 | C 95-03-06 (SEG) |
---|
| 109 | C Increased MAXX1 from 1000 to 5000. |
---|
| 110 | C |
---|
| 111 | C 94-08-03 (SEG) |
---|
| 112 | C Modified TMON3 to test each value of X each call. |
---|
| 113 | C |
---|
| 114 | C 94-01-03 (SEG) |
---|
| 115 | C Increased MAXV to 70. |
---|
| 116 | C |
---|
| 117 | C 92-11-02 (SEG) |
---|
| 118 | C Increased MAXX1 from 300 to 1000. |
---|
| 119 | C |
---|
| 120 | C 92-06-09 (SEG) |
---|
| 121 | C Increased MAXV to 50. |
---|
| 122 | C |
---|
| 123 | C 92-02-11 (SEG) |
---|
| 124 | C Modified PARFLT to check for blank space separators between |
---|
| 125 | C numeric values. |
---|
| 126 | C |
---|
| 127 | C 92-01-18 (SEG) |
---|
| 128 | C Modified CKNPC subroutine to properly check last line of the |
---|
| 129 | C data file. The main concern was to flag the last line if it |
---|
| 130 | C is not properly terminated. |
---|
| 131 | C |
---|
| 132 | C 91-12-17 (SEG) |
---|
| 133 | C Modified file header reading routines to use PARHD and TIXN to |
---|
| 134 | C read and test numeric values in place of RHINT, RHMISS, RHSCAL. |
---|
| 135 | C This change was to ensure that blank lines preceding numeric |
---|
| 136 | C values are flagged, and that commas used as field delimiters |
---|
| 137 | C will be flagged. |
---|
| 138 | C |
---|
| 139 | C 91-10-25 (SEG) |
---|
| 140 | C Added code in PD2160 to check lengths of character strings. |
---|
| 141 | C |
---|
| 142 | C 91-10-23 (SEG) |
---|
| 143 | C Added PARSIT option to eliminate the bugs outlined above, |
---|
| 144 | C and to flag the following conditions: |
---|
| 145 | C Non-numeric characters in the data records; |
---|
| 146 | C Excess number of values within a data record; |
---|
| 147 | C Blank lines within the data records; |
---|
| 148 | C Excessive padding of data records with spaces. |
---|
| 149 | C Also added code to terminate file checking/reading if NDIAG > 50. |
---|
| 150 | C Corrected bugs pointed out by J.Wild in RDATA, PRDATA, RD2310 to |
---|
| 151 | C omit testing/printing of X1 if NX(1)=AMISS(1) or NX(1)=0. |
---|
| 152 | C |
---|
| 153 | C 91-10-09 (SEG) |
---|
| 154 | C Modified RHBGIN to ensure that MNAME0 is the first non-blank |
---|
| 155 | C character string in MNAME. Included FRSTNB to help with this |
---|
| 156 | C task. |
---|
| 157 | C |
---|
| 158 | C 91-08-13 (SEG) |
---|
| 159 | C Modified CKNPC to test last line for nonprintable characters in |
---|
| 160 | C the event that an end-of-file designator appears before an |
---|
| 161 | C end-of-line. |
---|
| 162 | C |
---|
| 163 | C 91-08-09 (SEG) |
---|
| 164 | C Modified test at the end of this main program to only print a |
---|
| 165 | C warning about nonconstant number of lines per independent |
---|
| 166 | C variable mark when the format does not allow for a variable |
---|
| 167 | C number for NX(1) in the auxiliary variable list. |
---|
| 168 | C |
---|
| 169 | C 91-07-03 (SEG) |
---|
| 170 | C Modified CKNPC to return NLINES, and added code near the end of |
---|
| 171 | C this routine to print the number of lines per independent |
---|
| 172 | C variable mark. |
---|
| 173 | C |
---|
| 174 | C 91-06-28 (SEG) |
---|
| 175 | C Modified RDATA, TRIVM, and TSTDX to be more lenient with the |
---|
| 176 | C definition of constant data intervals (DX(s) not 0). TSTDX |
---|
| 177 | C was also changed to be able to test more than one value of DX |
---|
| 178 | C per call. |
---|
| 179 | C |
---|
| 180 | C Modified CH2FLT so that lower case `e' in exponential notation |
---|
| 181 | C is not flagged as an error. |
---|
| 182 | C |
---|
| 183 | C |
---|
| 184 | C S.E.Gaines, April 1991. |
---|
| 185 | C========================= |
---|
| 186 | C |
---|
| 187 | C |
---|
| 188 | PARAMETER ( MAXA = 70 ) |
---|
| 189 | PARAMETER ( MAXCA = 25 ) |
---|
| 190 | PARAMETER ( MAXCOM = 100 ) |
---|
| 191 | PARAMETER ( MAXCPL = 132 ) |
---|
| 192 | PARAMETER ( MAXIV = 4 ) |
---|
| 193 | PARAMETER ( MAXV = 70 ) |
---|
| 194 | PARAMETER ( MAXX1 =5000 ) |
---|
| 195 | PARAMETER ( MAXX2 = 200 ) |
---|
| 196 | PARAMETER ( MAXX3 = 30 ) |
---|
| 197 | PARAMETER ( MXCFLG = 2 ) |
---|
| 198 | C |
---|
| 199 | LOGICAL CHCKNP, EXISTS, PARSIT, PRNTIT, RETDAT, DBHEAD |
---|
| 200 | C |
---|
| 201 | CHARACTER*(MAXCPL) ANAME( MAXA ) |
---|
| 202 | CHARACTER*(MAXCPL) CA( MAXCA ) |
---|
| 203 | CHARACTER*(MAXCPL) CAMISS( MAXCA ) |
---|
| 204 | CHARACTER*255 CDUM |
---|
| 205 | CHARACTER*1 CFLG( MXCFLG ) |
---|
| 206 | CHARACTER*6 CRFMT |
---|
| 207 | CHARACTER*6 CWFMT |
---|
| 208 | CHARACTER*(MAXCPL) CX2 |
---|
| 209 | CHARACTER*(MAXCPL) FCTLZ |
---|
| 210 | CHARACTER*(MAXCPL) FILSPC |
---|
| 211 | CHARACTER*(MAXCPL) MNAME |
---|
| 212 | CHARACTER*(MAXCPL) MNAME0 |
---|
| 213 | CHARACTER*(MAXCPL) NCOM( MAXCOM ) |
---|
| 214 | CHARACTER*(MAXCPL) ONAME |
---|
| 215 | CHARACTER*(MAXCPL) ORG |
---|
| 216 | CHARACTER*(MAXCPL) SCOM( MAXCOM ) |
---|
| 217 | CHARACTER*(MAXCPL) SNAME |
---|
| 218 | CHARACTER*(MAXCPL) VNAME( MAXV ) |
---|
| 219 | CHARACTER*(MAXCPL) XNAME( MAXIV ) |
---|
| 220 | C |
---|
| 221 | DIMENSION A( MAXA ), AMISS( MAXA ), ASCAL( MAXA ) |
---|
| 222 | DIMENSION DX( MAXIV ), DUM( MAXX1 ) |
---|
| 223 | DIMENSION KFLG( MXCFLG ) |
---|
| 224 | DIMENSION LENA( MAXCA ), LENX( MAXIV ) |
---|
| 225 | DIMENSION NX( MAXIV ), NXDEF( MAXIV ) |
---|
| 226 | DIMENSION V( MAXX1,MAXV ), VMISS( MAXV ), VSCAL( MAXV ) |
---|
| 227 | DIMENSION X1( MAXX1 ), X2( MAXX2 ), X3( MAXX3 ) |
---|
| 228 | C |
---|
| 229 | C Define logical unit numbers. |
---|
| 230 | C IUN = data file. |
---|
| 231 | C IIU = input file. |
---|
| 232 | C IOU = output file containing diagnostics. |
---|
| 233 | C ISU = scratch file for writing and reading 3-D and 4-D data. |
---|
| 234 | C IZU = file whose name is defined by FCTLZ and contains the results |
---|
| 235 | C of the search for ^Zs. |
---|
| 236 | C |
---|
| 237 | DATA IUN / 21 / |
---|
| 238 | DATA IIU / 5 / |
---|
| 239 | DATA IOU / 6 / |
---|
| 240 | DATA ISU / 77 / |
---|
| 241 | DATA IZU / 88 / |
---|
| 242 | C |
---|
| 243 | C Define default values for logical variables. |
---|
| 244 | C CHCKNP = .TRUE. = check data file for non-printable characters |
---|
| 245 | C before reading the data values. |
---|
| 246 | C EXISTS = .TRUE. = file FCTLZ exists and there are ^Zs in the |
---|
| 247 | C the data file. |
---|
| 248 | C PARSIT = .TRUE. = numeric data records are `parsed' and checked for |
---|
| 249 | C extra numeric values. |
---|
| 250 | C = .FALSE. = numeric data records are read with `free format' |
---|
| 251 | C READ statements. |
---|
| 252 | C PRNTIT = .TRUE. = print contents of data file. |
---|
| 253 | C RETDAT = .TRUE. = 3-D and 4-D primary variable values are written to |
---|
| 254 | C the unformatted scratch file in the same order as they were |
---|
| 255 | C read from the data file. The scratch file is rewound and |
---|
| 256 | C properly positioned for reading the values after calling |
---|
| 257 | C subroutine RDATA. |
---|
| 258 | C DBHEAD = .TRUE. = the datafile contains a UARS header that must be skipped |
---|
| 259 | C over. |
---|
| 260 | C |
---|
| 261 | C |
---|
| 262 | DATA CHCKNP / .TRUE. / |
---|
| 263 | DATA EXISTS / .FALSE. / |
---|
| 264 | DATA PARSIT / .TRUE. / |
---|
| 265 | DATA PRNTIT / .FALSE. / |
---|
| 266 | DATA RETDAT / .FALSE. / |
---|
| 267 | DATA DBHEAD / .TRUE. / |
---|
| 268 | C |
---|
| 269 | C |
---|
| 270 | C Define format for reading character data. |
---|
| 271 | C |
---|
| 272 | WRITE( CRFMT,FMT='(2H(A,I3,1H))' ) MAXCPL |
---|
| 273 | C |
---|
| 274 | C Define ASCII characters to flag and count in routine CKNPC. |
---|
| 275 | C |
---|
| 276 | NFLG = 1 |
---|
| 277 | CFLG(1) = CHAR( 9 ) |
---|
| 278 | C |
---|
| 279 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
---|
| 280 | C Define/open input, output and scratch files (IIU, IOU, ISU). |
---|
| 281 | C |
---|
| 282 | C+UNIX |
---|
| 283 | C In this case the input and output files are defined on the |
---|
| 284 | C command line which executes this program. |
---|
| 285 | C |
---|
| 286 | c OPEN( IIU, STATUS='OLD' ) |
---|
| 287 | c OPEN( IOU, STATUS='NEW' ) |
---|
| 288 | OPEN( ISU, STATUS='SCRATCH',FORM='UNFORMATTED' ) |
---|
| 289 | C-UNIX |
---|
| 290 | C+VMS |
---|
| 291 | C In this case the input and output files are defined as |
---|
| 292 | C DEXDIR:DATAEX.IN and DEXDIR:DATAEX.OUT, where DEXDIR is the logical |
---|
| 293 | C name for the directory containing the files DATAEX.IN and DATAEX.OUT. |
---|
| 294 | C |
---|
| 295 | C OPEN( IIU, FILE='DEXDIR:DATAEX.IN', STATUS='OLD' ) |
---|
| 296 | C OPEN( IOU, FILE='DEXDIR:DATAEX.OUT',STATUS='NEW', |
---|
| 297 | C * CARRIAGECONTROL='LIST' ) |
---|
| 298 | C OPEN( ISU, STATUS='SCRATCH',FORM='UNFORMATTED' ) |
---|
| 299 | C-VMS |
---|
| 300 | C |
---|
| 301 | C Re-define the program control variables if necessary. |
---|
| 302 | C MNAME0 is the standard mission name. |
---|
| 303 | C FCTLZ is the name of the file containing the results of the |
---|
| 304 | C search for ^Zs by some external process. |
---|
| 305 | C |
---|
| 306 | C In this case they are read from the input file. |
---|
| 307 | C |
---|
| 308 | READ( IIU,FMT='(L1)' ) CHCKNP |
---|
| 309 | READ( IIU,FMT='(L1)' ) PARSIT |
---|
| 310 | READ( IIU,FMT='(L1)' ) RETDAT |
---|
| 311 | READ( IIU,FMT='(L1)' ) PRNTIT |
---|
| 312 | READ( IIU,FMT='(L1)' ) DBHEAD |
---|
| 313 | READ( IIU,FMT=CRFMT ) MNAME0 |
---|
| 314 | READ( IIU,FMT=CRFMT ) FCTLZ |
---|
| 315 | IF( PRNTIT ) RETDAT = .TRUE. |
---|
| 316 | C----------------------------------------------------------------------- |
---|
| 317 | C |
---|
| 318 | C Print values of the program control variables. |
---|
| 319 | C |
---|
| 320 | WRITE(IOU,*) 'Program control variables:' |
---|
| 321 | WRITE(IOU,FMT='(9H CHCKNP=,L1)') CHCKNP |
---|
| 322 | WRITE(IOU,FMT='(9H PARSIT=,L1)') PARSIT |
---|
| 323 | WRITE(IOU,FMT='(9H PRNTIT=,L1)') PRNTIT |
---|
| 324 | WRITE(IOU,FMT='(9H RETDAT=,L1)') RETDAT |
---|
| 325 | WRITE(IOU,FMT='(9H DBHEAD=,L1)') DBHEAD |
---|
| 326 | C |
---|
| 327 | CDUM = ' '//MNAME0 |
---|
| 328 | CALL LASTNB ( CDUM, LEN(CDUM), LNB ) |
---|
| 329 | CALL CHFMT ( LNB, CWFMT ) |
---|
| 330 | WRITE(IOU,*) ' MNAME0:' |
---|
| 331 | WRITE(IOU,FMT=CWFMT) CDUM |
---|
| 332 | C |
---|
| 333 | CDUM = ' CRFMT='//CRFMT |
---|
| 334 | CALL LASTNB ( CDUM, LEN(CDUM), LNB ) |
---|
| 335 | CALL CHFMT ( LNB, CWFMT ) |
---|
| 336 | WRITE(IOU,FMT=CWFMT) CDUM |
---|
| 337 | C |
---|
| 338 | WRITE(IOU,*) ' ASCII decimal values of nonprintable characters', |
---|
| 339 | * ' to be flagged and counted:' |
---|
| 340 | WRITE(IOU,FMT='(20I4)') ( ICHAR(CFLG(I)), I=1,NFLG ) |
---|
| 341 | C |
---|
| 342 | C Open IZU if file FCTLZ exits. |
---|
| 343 | C |
---|
| 344 | CALL LASTNB ( FCTLZ, LEN(FCTLZ), NCFZ ) |
---|
| 345 | INQUIRE( FILE=FCTLZ(1:NCFZ),EXIST=EXISTS ) |
---|
| 346 | IF( EXISTS ) THEN |
---|
| 347 | OPEN( IZU,FILE=FCTLZ(1:NCFZ),STATUS='OLD' ) |
---|
| 348 | ENDIF |
---|
| 349 | C |
---|
| 350 | C Loop on data files. |
---|
| 351 | C |
---|
| 352 | NFILES = 0 |
---|
| 353 | 100 CONTINUE |
---|
| 354 | NDIAG = 0 |
---|
| 355 | C |
---|
| 356 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
---|
| 357 | C Define/open the data file (IUN). FILSPC contains the complete |
---|
| 358 | C file specification (path name) of the data file. |
---|
| 359 | C |
---|
| 360 | C In this case FILSPC is read from the input file. |
---|
| 361 | C |
---|
| 362 | READ( IIU,FMT=CRFMT,END=300 ) FILSPC |
---|
| 363 | PRINT *, FILSPC |
---|
| 364 | CALL LASTNB ( FILSPC, LEN(FILSPC), NCFS ) |
---|
| 365 | WRITE( IOU,* ) ' ' |
---|
| 366 | WRITE( IOU,* ) 'Reading file '//FILSPC(1:NCFS) |
---|
| 367 | C+UNIX |
---|
| 368 | OPEN( IUN,FILE=FILSPC(1:NCFS),STATUS='OLD' ) |
---|
| 369 | C-UNIX |
---|
| 370 | C+VMS |
---|
| 371 | C OPEN( IUN,FILE=FILSPC(1:NCFS),STATUS='OLD',READONLY ) |
---|
| 372 | C-VMS |
---|
| 373 | C----------------------------------------------------------------------- |
---|
| 374 | NFILES = NFILES + 1 |
---|
| 375 | C |
---|
| 376 | C Check for non-printable characters. |
---|
| 377 | C |
---|
| 378 | NLINES = 0 |
---|
| 379 | IF( CHCKNP ) THEN |
---|
| 380 | IF( EXISTS ) THEN |
---|
| 381 | CALL FGCTLZ ( FILSPC, NCFS, CRFMT, CDUM, NDIAG, |
---|
| 382 | * IZU, IOU ) |
---|
| 383 | ENDIF |
---|
| 384 | IF (DBHEAD) READ (IUN,*) |
---|
| 385 | CALL CKNPC ( CDUM, CFLG, KFLG, NFLG, MAXCPL, |
---|
| 386 | * NLINES, NDIAG, IUN, IOU ) |
---|
| 387 | REWIND IUN |
---|
| 388 | ENDIF |
---|
| 389 | C |
---|
| 390 | C Read file header. |
---|
| 391 | C All relevant file header info is returned by subroutine RHEAD. |
---|
| 392 | C |
---|
| 393 | CALL RHEAD ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 394 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 395 | * DX, NX, NXDEF, LENX, XNAME, X1, X2, X3, |
---|
| 396 | * NV, NVPM, VSCAL, VMISS, VNAME, |
---|
| 397 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 398 | * NAUXC, LENA, CAMISS, |
---|
| 399 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 400 | * MAXX1, MAXX2, MAXX3, |
---|
| 401 | * MAXV, MAXA, MAXCA, MAXCOM, MAXCPL, CDUM, |
---|
| 402 | * MNAME0, CRFMT, IUN, IOU, ISUBV, NDIAG, IERR, |
---|
| 403 | * DBHEAD ) |
---|
| 404 | IF( IERR .NE. 0 ) GO TO 290 |
---|
| 405 | IF( PRNTIT ) THEN |
---|
| 406 | CALL PRHEAD ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 407 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 408 | * DX, NX, NXDEF, LENX, XNAME, X1, X2, X3, |
---|
| 409 | * NV, NVPM, VSCAL, VMISS, VNAME, |
---|
| 410 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 411 | * NAUXC, LENA, CAMISS, |
---|
| 412 | * NSCOML, SCOM, NNCOML, NCOM, CWFMT, IOU ) |
---|
| 413 | ENDIF |
---|
| 414 | C |
---|
| 415 | C Loop on reading data records. |
---|
| 416 | C One independent variable mark and all associated auxiliary, |
---|
| 417 | C independent, and primary variable values are returned with |
---|
| 418 | C each call to subroutine RDATA. |
---|
| 419 | C For 3-D and 4-D primary variables (eg. FFI=3010 and 4010), |
---|
| 420 | C the primary variable values are written to the unformatted |
---|
| 421 | C scratch file in the same order as they were read from the |
---|
| 422 | C data file, and can be read from the scratch file after |
---|
| 423 | C calling subroutine RDATA. |
---|
| 424 | C |
---|
| 425 | LINE = NLHEAD |
---|
| 426 | NCIDR = 0 |
---|
| 427 | NBIDR = 0 |
---|
| 428 | NIVM = 0 |
---|
| 429 | NVALS = 0 |
---|
| 430 | 230 CONTINUE |
---|
| 431 | IF( RETDAT .AND. IFFI .GT. 2999 ) REWIND ISU |
---|
| 432 | CALL RDATA ( X1, X2, X3, X4, CX2, LENX, DX, NX, |
---|
| 433 | * A, AMISS, CA, CAMISS, LENA, NAUXV, NAUXC, |
---|
| 434 | * V, VMISS, MAXX1, NV, NVPM, |
---|
| 435 | * CDUM, DUM, LINE, NBIDR, NCIDR, NVALS, |
---|
| 436 | * CRFMT, RETDAT, PARSIT, |
---|
| 437 | * IUN, IOU, ISU, NIVM, |
---|
| 438 | * ISUBV, NDIAG, IERR ) |
---|
| 439 | IF( IERR .NE. 0 ) GO TO 288 |
---|
| 440 | IF( RETDAT .AND. IFFI .GT. 2999 ) REWIND ISU |
---|
| 441 | IF( PRNTIT ) THEN |
---|
| 442 | CALL PRDATA ( X1, X2, X3, X4, CX2, LENX, DX, NX, |
---|
| 443 | * A, AMISS, CA, LENA, NAUXV, NAUXC, |
---|
| 444 | * V, MAXX1, NV, NVPM, CWFMT, IOU, ISU, |
---|
| 445 | * ISUBV ) |
---|
| 446 | IF( IFFI .GT. 2999 ) REWIND ISU |
---|
| 447 | ENDIF |
---|
| 448 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
---|
| 449 | C At this point, all data values associated with the current |
---|
| 450 | C independent variable mark are available for user-defined |
---|
| 451 | C routines. Values of 3-D and 4-D primary variables must be |
---|
| 452 | C read from the scratch file (unit ISU). |
---|
| 453 | C----------------------------------------------------------------------- |
---|
| 454 | C |
---|
| 455 | C Terminate reading/checking of the file if there are too |
---|
| 456 | C many error diagnostics. |
---|
| 457 | C |
---|
| 458 | IF( NDIAG .GT. 50 ) THEN |
---|
| 459 | WRITE( IOU,* ) ' !!!! TOO MANY ERRORS, I QUIT !!!!' |
---|
| 460 | ELSE |
---|
| 461 | GO TO 230 |
---|
| 462 | ENDIF |
---|
| 463 | 288 CONTINUE |
---|
| 464 | IF( NIVM .LT. 1 ) THEN |
---|
| 465 | WRITE(IOU,*) ' **No complete data records were found' |
---|
| 466 | NDIAG = NDIAG + 1 |
---|
| 467 | ENDIF |
---|
| 468 | IF( NCIDR .GT. 5000 ) THEN |
---|
| 469 | IPCB = INT( 100.0*FLOAT(NBIDR-NVALS)/FLOAT(NCIDR) ) |
---|
| 470 | IF( IPCB .GT. 25 ) THEN |
---|
| 471 | WRITE( IOU,FMT='(3X,14H*ADMONITION-- ,I2, |
---|
| 472 | * 49H% of the data records are extraneous blank spaces)' ) |
---|
| 473 | * IPCB |
---|
| 474 | ENDIF |
---|
| 475 | ENDIF |
---|
| 476 | WRITE( IOU,* ) ' Number of lines in file header=', NLHEAD |
---|
| 477 | WRITE( IOU,* ) ' Number of successfully read independent' |
---|
| 478 | WRITE( IOU,* ) ' variable marks and associated data=', NIVM |
---|
| 479 | 290 CONTINUE |
---|
| 480 | IF( NDIAG .GT. 0 ) THEN |
---|
| 481 | WRITE( IOU,* ) ' Number of diagnostics=', NDIAG |
---|
| 482 | WRITE( IOU,* ) |
---|
| 483 | * '****** File format is not acceptable ******' |
---|
| 484 | WRITE( IOU,* ) |
---|
| 485 | * '****** Please make corrections and try again ******' |
---|
| 486 | ELSE |
---|
| 487 | IF( NLINES .GT. 0 ) THEN |
---|
| 488 | NLDATA = NLINES - NLHEAD |
---|
| 489 | NLPIVM = NLDATA / NIVM |
---|
| 490 | FLPIVM = FLOAT( NLDATA ) / FLOAT( NIVM ) |
---|
| 491 | IF( NIVM*NLPIVM .NE. NLDATA .AND. IFFI .NE. 2110 .AND. |
---|
| 492 | * IFFI .NE. 2160 .AND. IFFI .NE. 2310 ) THEN |
---|
| 493 | WRITE( IOU,* ) |
---|
| 494 | * '?????? File format looks ok except that the ??????' |
---|
| 495 | WRITE( IOU,* ) |
---|
| 496 | * '?????? number of lines of data per independent ??????' |
---|
| 497 | WRITE( IOU,* ) |
---|
| 498 | * '?????? variable mark is not a constant ??????' |
---|
| 499 | WRITE( IOU,* ) |
---|
| 500 | * ' Number of lines per independent variable mark=',FLPIVM |
---|
| 501 | ELSE |
---|
| 502 | WRITE( IOU,* ) |
---|
| 503 | * ' Number of lines per independent variable mark=',FLPIVM |
---|
| 504 | WRITE( IOU,* ) |
---|
| 505 | * '$$$$$$ Looks good! Thanks for the file $$$$$$' |
---|
| 506 | ENDIF |
---|
| 507 | ELSE |
---|
| 508 | WRITE( IOU,* ) |
---|
| 509 | * '$$$$$$ Looks good! Thanks for the file $$$$$$' |
---|
| 510 | ENDIF |
---|
| 511 | ENDIF |
---|
| 512 | CLOSE( IUN ) |
---|
| 513 | GO TO 100 |
---|
| 514 | 300 CONTINUE |
---|
| 515 | WRITE( IOU,* ) ' ' |
---|
| 516 | WRITE( IOU,* ) ' Number of files read=', NFILES |
---|
| 517 | C |
---|
| 518 | C Delete IZU if it has been opened. |
---|
| 519 | C |
---|
| 520 | IF( EXISTS ) THEN |
---|
| 521 | CLOSE(IZU,STATUS='DELETE') |
---|
| 522 | ENDIF |
---|
| 523 | END |
---|
| 524 | SUBROUTINE CH2FLT ( C, I1, I2, N1, N2, VAL, IFLAG, NDIAG, IOU ) |
---|
| 525 | C |
---|
| 526 | C Given a character string, C, and location limits to search (I1,I2), |
---|
| 527 | C this routine looks for and extracts the first floating point number |
---|
| 528 | C (VAL) it can find, including sign and decimal point. |
---|
| 529 | C VAL starts with a number, + or - or decimal point, and ends with the |
---|
| 530 | C first non-numeric character (other than +, -, ., or E). |
---|
| 531 | C N1 and N2 are the location limits within which it found VAL. |
---|
| 532 | C If IFLAG is returned as zero then no VAL was found. |
---|
| 533 | C |
---|
| 534 | C Required routines: CH2INT. |
---|
| 535 | C |
---|
| 536 | C History: |
---|
| 537 | C 91-06-27 (SEG) Commented out the code to issue an error diagnostic |
---|
| 538 | C if `e' is used in exponential notation. |
---|
| 539 | C |
---|
| 540 | C |
---|
| 541 | CHARACTER*(*) C |
---|
| 542 | CHARACTER*8 IFMT |
---|
| 543 | C |
---|
| 544 | IFLAG = 0 |
---|
| 545 | NDEC = 0 |
---|
| 546 | NEXP = 0 |
---|
| 547 | NSIGN1= 0 |
---|
| 548 | NSIGN2= 0 |
---|
| 549 | C |
---|
| 550 | C Locate first integer number (NS1, NE1). |
---|
| 551 | C |
---|
| 552 | CALL CH2INT ( C, I1, I2, NS1, NE1, IVAL1 ) |
---|
| 553 | IF( IVAL1 .LT. 0 ) GO TO 100 |
---|
| 554 | N1 = NS1 |
---|
| 555 | N2 = NE1 |
---|
| 556 | C |
---|
| 557 | C Check for decimal before IVAL1. |
---|
| 558 | C |
---|
| 559 | IF( NS1 .GT. I1 ) THEN |
---|
| 560 | IF( C(NS1-1:NS1-1) .EQ. '.' ) THEN |
---|
| 561 | NDEC = NS1 - 1 |
---|
| 562 | N1 = NS1 - 1 |
---|
| 563 | ENDIF |
---|
| 564 | ENDIF |
---|
| 565 | C |
---|
| 566 | C Check for sign before IVAL1. |
---|
| 567 | C |
---|
| 568 | IF( N1 .GT. I1 ) THEN |
---|
| 569 | IF( C(N1-1:N1-1) .EQ. '-' .OR. C(N1-1:N1-1) .EQ. '+' ) THEN |
---|
| 570 | NSIGN1 = N1 - 1 |
---|
| 571 | N1 = N1 - 1 |
---|
| 572 | ENDIF |
---|
| 573 | ENDIF |
---|
| 574 | C |
---|
| 575 | C Check for a fractional number after IVAL1. |
---|
| 576 | C |
---|
| 577 | IF( NDEC .LT. 1 ) THEN |
---|
| 578 | IF( N2 .LT. I2 ) THEN |
---|
| 579 | IF( C(N2+1:N2+1) .EQ. '.' ) THEN |
---|
| 580 | NDEC = N2 + 1 |
---|
| 581 | N2 = N2 + 1 |
---|
| 582 | C |
---|
| 583 | C Check for fraction after the decimal point. |
---|
| 584 | C |
---|
| 585 | IF( N2 .LT. I2 ) THEN |
---|
| 586 | IF( C(N2+1:N2+1) .GE. '0' .AND. |
---|
| 587 | * C(N2+1:N2+1) .LE. '9' ) THEN |
---|
| 588 | |
---|
| 589 | CALL CH2INT ( C, NDEC+1, I2, NS2, NE2, IVAL2 ) |
---|
| 590 | IF( IVAL2 .GE. 0 ) N2 = NE2 |
---|
| 591 | ENDIF |
---|
| 592 | ENDIF |
---|
| 593 | ENDIF |
---|
| 594 | ENDIF |
---|
| 595 | ENDIF |
---|
| 596 | C |
---|
| 597 | C Check for exponent. |
---|
| 598 | C |
---|
| 599 | IF( N2 .LT. I2 ) THEN |
---|
| 600 | IF( C(N2+1:N2+1) .EQ. 'E' .OR. C(N2+1:N2+1) .EQ. 'e' ) THEN |
---|
| 601 | C IF( C(N2+1:N2+1) .EQ. 'e' ) THEN |
---|
| 602 | C WRITE( IOU,* ) |
---|
| 603 | C * ' **Non-standard exponential notation. Use E instead of e.' |
---|
| 604 | C NDIAG = NDIAG + 1 |
---|
| 605 | C ENDIF |
---|
| 606 | IF( C(N2+2:N2+2) .EQ. '+' .OR. C(N2+2:N2+2) .EQ. '-' ) THEN |
---|
| 607 | IF( C(N2+3:N2+3) .GE. '0' .AND. |
---|
| 608 | * C(N2+3:N2+3) .LE. '9' ) THEN |
---|
| 609 | CALL CH2INT ( C, N2+3, I2, NS3, NE3, IVEXP ) |
---|
| 610 | NEXP = N2 + 1 |
---|
| 611 | NSIGN2 = N2 + 2 |
---|
| 612 | N2 = NE3 |
---|
| 613 | ELSE |
---|
| 614 | NEXP = N2 + 1 |
---|
| 615 | NSIGN2 = N2 + 2 |
---|
| 616 | IVEXP = 0 |
---|
| 617 | N2 = N2 + 2 |
---|
| 618 | ENDIF |
---|
| 619 | ELSE IF( C(N2+2:N2+2) .LT. '0' .OR. |
---|
| 620 | * C(N2+2:N2+2) .GT. '9' ) THEN |
---|
| 621 | NEXP = N2 + 1 |
---|
| 622 | IVEXP = 0 |
---|
| 623 | N2 = N2 + 1 |
---|
| 624 | ELSE |
---|
| 625 | CALL CH2INT ( C, N2+2, I2, NS3, NE3, IVEXP ) |
---|
| 626 | NEXP = N2 + 1 |
---|
| 627 | N2 = NE3 |
---|
| 628 | ENDIF |
---|
| 629 | ENDIF |
---|
| 630 | ENDIF |
---|
| 631 | C |
---|
| 632 | C Setup format for decoding the number, and decode it. |
---|
| 633 | C |
---|
| 634 | NTOT = N2 - N1 + 1 |
---|
| 635 | IF( NEXP .GT. 0 .AND. NDEC .GT. 0 ) THEN |
---|
| 636 | ND = NEXP - NDEC - 1 |
---|
| 637 | ELSE IF( NEXP .GT. 0 ) THEN |
---|
| 638 | ND = 0 |
---|
| 639 | ELSE IF( NDEC .GT. 0 ) THEN |
---|
| 640 | ND = N2 - NDEC |
---|
| 641 | ELSE |
---|
| 642 | ND = 0 |
---|
| 643 | ENDIF |
---|
| 644 | WRITE(IFMT,FMT='(2H(F,I2,1H.,I2,1H))') NTOT, ND |
---|
| 645 | READ (C(N1:N2),FMT=IFMT) VAL |
---|
| 646 | IFLAG = 1 |
---|
| 647 | 100 CONTINUE |
---|
| 648 | RETURN |
---|
| 649 | END |
---|
| 650 | SUBROUTINE CH2INT ( C, I1, I2, N1, N2, IVAL ) |
---|
| 651 | C |
---|
| 652 | C Given a character string, C, and location limits to search (I1,I2), |
---|
| 653 | C this routine looks for and extracts the first positive integer |
---|
| 654 | C number (IVAL) it can find. The integer number starts with the first |
---|
| 655 | C numeric character encountered within the search limits, and ends |
---|
| 656 | C with the first non-numeric character encountered after a number. |
---|
| 657 | C N1 and N2 are the location limits within which it found the integer |
---|
| 658 | C number. |
---|
| 659 | C IVAL is returned as a negative number if no integer value can be |
---|
| 660 | C found. Otherwise it contains the positive integer value. |
---|
| 661 | C |
---|
| 662 | CHARACTER*(*) C |
---|
| 663 | CHARACTER*5 IFMT |
---|
| 664 | C |
---|
| 665 | IVAL = -1 |
---|
| 666 | C |
---|
| 667 | C Locate position of first numeric character. |
---|
| 668 | C |
---|
| 669 | DO 20 I=I1,I2 |
---|
| 670 | IF( C(I:I) .GE. '0' .AND. C(I:I) .LE. '9' ) THEN |
---|
| 671 | N1 = I |
---|
| 672 | GO TO 22 |
---|
| 673 | ENDIF |
---|
| 674 | 20 CONTINUE |
---|
| 675 | GO TO 50 |
---|
| 676 | 22 CONTINUE |
---|
| 677 | C |
---|
| 678 | C Locate first non-numeric character. |
---|
| 679 | C |
---|
| 680 | IF( N1 .EQ. I2 ) THEN |
---|
| 681 | N2 = N1 |
---|
| 682 | GO TO 32 |
---|
| 683 | ELSE |
---|
| 684 | DO 30 I=N1+1,I2 |
---|
| 685 | IF( C(I:I) .LT. '0' .OR. C(I:I) .GT. '9' ) THEN |
---|
| 686 | N2 = I - 1 |
---|
| 687 | GO TO 32 |
---|
| 688 | ENDIF |
---|
| 689 | 30 CONTINUE |
---|
| 690 | N2 = I2 |
---|
| 691 | ENDIF |
---|
| 692 | 32 CONTINUE |
---|
| 693 | C |
---|
| 694 | C Setup format for decoding the number, and decode it. |
---|
| 695 | C |
---|
| 696 | WRITE(IFMT,FMT='(2H(I,I2,1H))') N2-N1+1 |
---|
| 697 | READ (C(N1:N2),FMT=IFMT) IVAL |
---|
| 698 | 50 CONTINUE |
---|
| 699 | RETURN |
---|
| 700 | END |
---|
| 701 | SUBROUTINE CHFMT ( NCHAR, CWFMT ) |
---|
| 702 | C |
---|
| 703 | C Given NCHAR, the number of characters to be written, this |
---|
| 704 | C routine defines a character variable CWFMT containing the required |
---|
| 705 | C format for writing the character string as a left-justified string |
---|
| 706 | C of the proper length. |
---|
| 707 | C It is assumed that CWFMT is at least a CHARACTER*6 variable. |
---|
| 708 | C |
---|
| 709 | CHARACTER*(*) CWFMT |
---|
| 710 | C |
---|
| 711 | IF( NCHAR .LE. 0 ) THEN |
---|
| 712 | CWFMT = '(A1)' |
---|
| 713 | ELSE |
---|
| 714 | WRITE(CWFMT,FMT='(2H(A,I3,1H))') NCHAR |
---|
| 715 | ENDIF |
---|
| 716 | RETURN |
---|
| 717 | END |
---|
| 718 | SUBROUTINE CKMISV ( V, VMISS, NV, X, |
---|
| 719 | * VFLG, NVF, IVFLG, NIF, SFLG, NSF, |
---|
| 720 | * NDIAG, IOU ) |
---|
| 721 | C |
---|
| 722 | C Subroutine to test NV values of V(N) against their appropriate |
---|
| 723 | C missing values. |
---|
| 724 | C |
---|
| 725 | CHARACTER*(*) IVFLG |
---|
| 726 | CHARACTER*(*) SFLG |
---|
| 727 | CHARACTER*(*) VFLG |
---|
| 728 | C |
---|
| 729 | DIMENSION V( * ), VMISS( * ) |
---|
| 730 | C |
---|
| 731 | IF( NV .LT. 1 ) RETURN |
---|
| 732 | DO 30 N=1,NV |
---|
| 733 | IF( V(N) .GT. VMISS(N) ) THEN |
---|
| 734 | WRITE( IOU,* ) |
---|
| 735 | * ' **Error in CKMISV when called by ',SFLG(1:NSF) |
---|
| 736 | WRITE( IOU,* ) |
---|
| 737 | * ' ',VFLG(1:NVF),' .GT. its missing value for index ',N |
---|
| 738 | WRITE( IOU,* ) ' ',VFLG(1:NVF),'= ', V(N) |
---|
| 739 | WRITE( IOU,* ) ' at ',IVFLG(1:NIF),'= ', X |
---|
| 740 | NDIAG = NDIAG + 1 |
---|
| 741 | ENDIF |
---|
| 742 | 30 CONTINUE |
---|
| 743 | RETURN |
---|
| 744 | END |
---|
| 745 | SUBROUTINE CKMSXV ( V, IDIM, VMISS, NV, X, NX, |
---|
| 746 | * VFLG, NVF, IVFLG, NIF, SFLG, NSF, |
---|
| 747 | * NDIAG, IOU ) |
---|
| 748 | C |
---|
| 749 | C Subroutine to test values of V(I,N) against their appropriate |
---|
| 750 | C missing values. |
---|
| 751 | C |
---|
| 752 | CHARACTER*(*) IVFLG |
---|
| 753 | CHARACTER*(*) SFLG |
---|
| 754 | CHARACTER*(*) VFLG |
---|
| 755 | C |
---|
| 756 | DIMENSION V( IDIM,* ), VMISS( * ) |
---|
| 757 | C |
---|
| 758 | IF( NX .LT. 1 ) RETURN |
---|
| 759 | DO 50 N=1,NV |
---|
| 760 | BIG = -9.9E+20 |
---|
| 761 | DO 30 I=1,NX |
---|
| 762 | BIG = AMAX1( V(I,N), BIG ) |
---|
| 763 | 30 CONTINUE |
---|
| 764 | IF( BIG .GT. VMISS(N) ) THEN |
---|
| 765 | WRITE( IOU,* ) |
---|
| 766 | * ' **Error in CKMSXV when called by ',SFLG(1:NSF) |
---|
| 767 | WRITE( IOU,* ) |
---|
| 768 | * ' ',VFLG(1:NVF),' .GT. its missing value for index ',N |
---|
| 769 | WRITE( IOU,* ) ' ',VFLG(1:NVF),'= ', BIG |
---|
| 770 | WRITE( IOU,* ) ' at ',IVFLG(1:NIF),'= ', X |
---|
| 771 | NDIAG = NDIAG + 1 |
---|
| 772 | ENDIF |
---|
| 773 | 50 CONTINUE |
---|
| 774 | RETURN |
---|
| 775 | END |
---|
| 776 | SUBROUTINE CKNPC ( CDUM, CFLG, KFLG, NFLG, MAXLEN, |
---|
| 777 | * IREC, NDIAG, IUN, IOU ) |
---|
| 778 | C |
---|
| 779 | C Subroutine to check ASCII files for non-printable characters and |
---|
| 780 | C long records. |
---|
| 781 | C Record lengths greater than MAXLEN are flagged. |
---|
| 782 | C Characters with ASCII decimal values .LT. CMIN and .GT. CMAX |
---|
| 783 | C are flagged. |
---|
| 784 | C The contents of CFLG(I) denote characters outside the limits of |
---|
| 785 | C CMIN and CMAX which are counted with the number of finds stored |
---|
| 786 | C in KFLG(I). This option is for unwanted characters which are likely |
---|
| 787 | C to occur often. |
---|
| 788 | C |
---|
| 789 | C Required routines: LASTNB. |
---|
| 790 | C |
---|
| 791 | C History: |
---|
| 792 | C 92-01-18 (SEG) Modified to initialize CDUM=' ' before reading |
---|
| 793 | C a record, so that last line of file is |
---|
| 794 | C properly checked. |
---|
| 795 | C 91-08-13 (SEG) Modified to check last record. |
---|
| 796 | C 91-07-03 (SEG) Modified to return IREC. |
---|
| 797 | C |
---|
| 798 | C |
---|
| 799 | CHARACTER*(*) CFLG( * ) |
---|
| 800 | CHARACTER*(*) CDUM |
---|
| 801 | CHARACTER*1 CMAX |
---|
| 802 | CHARACTER*1 CMIN |
---|
| 803 | CHARACTER*6 CRFMT |
---|
| 804 | C |
---|
| 805 | DIMENSION KFLG( * ) |
---|
| 806 | C |
---|
| 807 | DATA CMAX / '~' / |
---|
| 808 | DATA CMIN / ' ' / |
---|
| 809 | C |
---|
| 810 | IREC = 0 |
---|
| 811 | DO 18 I=1,NFLG |
---|
| 812 | KFLG(I) = 0 |
---|
| 813 | 18 CONTINUE |
---|
| 814 | LCD = LEN( CDUM ) |
---|
| 815 | WRITE( CRFMT,FMT='(2H(A,I3,1H))' ) LCD |
---|
| 816 | 20 CONTINUE |
---|
| 817 | CDUM = ' ' |
---|
| 818 | READ( IUN,FMT=CRFMT,END=200 ) CDUM |
---|
| 819 | CALL LASTNB ( CDUM, LCD, N ) |
---|
| 820 | IREC = IREC + 1 |
---|
| 821 | IF( N .GT. MAXLEN ) THEN |
---|
| 822 | WRITE( IOU,* ) |
---|
| 823 | * ' **Line too long--line #, length=', IREC, N |
---|
| 824 | NDIAG = NDIAG + 1 |
---|
| 825 | ENDIF |
---|
| 826 | DO 40 I=1,N |
---|
| 827 | IF( CDUM(I:I) .LT. CMIN .OR. CDUM(I:I) .GT. CMAX ) THEN |
---|
| 828 | IF( NFLG .GT. 0 ) THEN |
---|
| 829 | DO 26 J=1,NFLG |
---|
| 830 | IF( CDUM(I:I) .EQ. CFLG(J) ) THEN |
---|
| 831 | KFLG(J) = KFLG(J) + 1 |
---|
| 832 | GO TO 40 |
---|
| 833 | ENDIF |
---|
| 834 | 26 CONTINUE |
---|
| 835 | ENDIF |
---|
| 836 | WRITE( IOU,* ) |
---|
| 837 | * ' **Found non-printable character with ASCII decimal value=', |
---|
| 838 | * ICHAR(CDUM(I:I)) |
---|
| 839 | WRITE( IOU,* ) ' at line number=', IREC |
---|
| 840 | NDIAG = NDIAG + 1 |
---|
| 841 | ENDIF |
---|
| 842 | 40 CONTINUE |
---|
| 843 | GO TO 20 |
---|
| 844 | 200 CONTINUE |
---|
| 845 | C |
---|
| 846 | C Check last line in the event that end-of-file characters are tacked |
---|
| 847 | C on to the end of the line without a proper end-of-line designator. |
---|
| 848 | C |
---|
| 849 | CALL LASTNB ( CDUM, LCD, N ) |
---|
| 850 | IF( N .GT. 0 ) THEN |
---|
| 851 | IF( N .GT. MAXLEN ) THEN |
---|
| 852 | WRITE( IOU,* ) |
---|
| 853 | * ' **Last line too long--length=', N |
---|
| 854 | NDIAG = NDIAG + 1 |
---|
| 855 | ENDIF |
---|
| 856 | DO 240 I=1,N |
---|
| 857 | IF( CDUM(I:I) .LT. CMIN .OR. CDUM(I:I) .GT. CMAX ) THEN |
---|
| 858 | IF( NFLG .GT. 0 ) THEN |
---|
| 859 | DO 226 J=1,NFLG |
---|
| 860 | IF( CDUM(I:I) .EQ. CFLG(J) ) THEN |
---|
| 861 | KFLG(J) = KFLG(J) + 1 |
---|
| 862 | GO TO 240 |
---|
| 863 | ENDIF |
---|
| 864 | 226 CONTINUE |
---|
| 865 | ENDIF |
---|
| 866 | WRITE( IOU,* ) |
---|
| 867 | * ' **Found non-printable character with ASCII decimal value=', |
---|
| 868 | * ICHAR(CDUM(I:I)) |
---|
| 869 | WRITE( IOU,* ) ' in last line of file.' |
---|
| 870 | NDIAG = NDIAG + 1 |
---|
| 871 | ENDIF |
---|
| 872 | 240 CONTINUE |
---|
| 873 | C |
---|
| 874 | C Flag last line if N>0. There should only be an EOF. |
---|
| 875 | C |
---|
| 876 | WRITE(IOU,*) ' **Last line improperly terminated' |
---|
| 877 | NDIAG = NDIAG + 1 |
---|
| 878 | ENDIF |
---|
| 879 | C |
---|
| 880 | C Print summary of flagged characters. |
---|
| 881 | C |
---|
| 882 | IF( NFLG .GT. 0 ) THEN |
---|
| 883 | DO 250 I=1,NFLG |
---|
| 884 | IF( KFLG(I) .GT. 0 ) THEN |
---|
| 885 | WRITE( IOU,* ) |
---|
| 886 | * ' **Found non-printable character with ASCII decimal value=', |
---|
| 887 | * ICHAR(CFLG(I)) |
---|
| 888 | WRITE(IOU,*) ' Number of occurrences=', KFLG(I) |
---|
| 889 | NDIAG = NDIAG + 1 |
---|
| 890 | ENDIF |
---|
| 891 | 250 CONTINUE |
---|
| 892 | ENDIF |
---|
| 893 | WRITE( IOU,* ) ' Number of lines read by CKNPC= ', IREC |
---|
| 894 | RETURN |
---|
| 895 | END |
---|
| 896 | SUBROUTINE CNTBLA ( C, I1, I2, NBLANK ) |
---|
| 897 | C |
---|
| 898 | C Given a character string, C, and location limits to search (I1,I2), |
---|
| 899 | C this routine counts the number of blank spaces within the search |
---|
| 900 | C limits. |
---|
| 901 | C |
---|
| 902 | CHARACTER*(*) C |
---|
| 903 | C |
---|
| 904 | NBLANK = 0 |
---|
| 905 | DO 30 I=I1,I2 |
---|
| 906 | IF( C(I:I) .EQ. ' ' ) NBLANK = NBLANK + 1 |
---|
| 907 | 30 CONTINUE |
---|
| 908 | RETURN |
---|
| 909 | END |
---|
| 910 | SUBROUTINE CNTNN ( C, I1, I2, NNN ) |
---|
| 911 | C |
---|
| 912 | C Given a character string, C, and location limits to search (I1,I2), |
---|
| 913 | C this routine counts the number of non-numeric printable characters |
---|
| 914 | C within the search limits. |
---|
| 915 | C Numeric characters are 0 1 2 3 4 5 6 7 8 9 . + - e E (and space). |
---|
| 916 | C |
---|
| 917 | CHARACTER*(*) C |
---|
| 918 | C |
---|
| 919 | NNN = 0 |
---|
| 920 | DO 30 I=I1,I2 |
---|
| 921 | IF( C(I:I) .GT. ' ' .AND. C(I:I) .LT. '0' ) THEN |
---|
| 922 | IF( C(I:I) .EQ. '+' .OR. |
---|
| 923 | * C(I:I) .EQ. '-' .OR. C(I:I) .EQ. '.' ) GO TO 30 |
---|
| 924 | NNN = NNN + 1 |
---|
| 925 | ELSE IF( C(I:I) .GT. '9' .AND. C(I:I) .LE. '~' ) THEN |
---|
| 926 | IF( C(I:I) .EQ. 'E' .OR. C(I:I) .EQ. 'e' ) GO TO 30 |
---|
| 927 | NNN = NNN + 1 |
---|
| 928 | ENDIF |
---|
| 929 | 30 CONTINUE |
---|
| 930 | RETURN |
---|
| 931 | END |
---|
| 932 | SUBROUTINE FGCTLZ ( FILSPC, NCFS, CRFMT, CDUM, NDIAG, IZU, IOU ) |
---|
| 933 | C |
---|
| 934 | C Subroutine to scan file in unit IZU for occurrences of ^Z and |
---|
| 935 | C note them in the output file. |
---|
| 936 | C |
---|
| 937 | C Required routines: LASTNB. |
---|
| 938 | C |
---|
| 939 | CHARACTER*10 CD2 |
---|
| 940 | CHARACTER*(*) CDUM |
---|
| 941 | CHARACTER*(*) CRFMT |
---|
| 942 | CHARACTER*(*) FILSPC |
---|
| 943 | C |
---|
| 944 | REWIND IZU |
---|
| 945 | 20 CONTINUE |
---|
| 946 | READ( IZU,FMT=CRFMT,END=200 ) CDUM |
---|
| 947 | L = INDEX( CDUM, FILSPC(1:NCFS) ) |
---|
| 948 | IF( L .NE. 1 ) GOTO 20 |
---|
| 949 | CALL LASTNB ( CDUM, LEN(CDUM), LNB ) |
---|
| 950 | WRITE(CD2,FMT='(1H(,I3,3HX,I,I2,1H))') NCFS+1, LNB-NCFS-1 |
---|
| 951 | READ( CDUM,FMT=CD2 ) LINO |
---|
| 952 | WRITE( IOU,* ) ' **Found ^Z in line number ', LINO |
---|
| 953 | NDIAG = NDIAG + 1 |
---|
| 954 | GOTO 20 |
---|
| 955 | 200 CONTINUE |
---|
| 956 | RETURN |
---|
| 957 | END |
---|
| 958 | SUBROUTINE FNDFLT ( C, X, NX, MAXX, NDIAG, IOU ) |
---|
| 959 | C |
---|
| 960 | C Subroutine to find all floating point numbers in a character string. |
---|
| 961 | C |
---|
| 962 | C Required routines: CH2FLT, LASTNB. |
---|
| 963 | C |
---|
| 964 | CHARACTER*(*) C |
---|
| 965 | C |
---|
| 966 | DIMENSION X( * ) |
---|
| 967 | C |
---|
| 968 | NX = 0 |
---|
| 969 | CALL LASTNB ( C, LEN(C), LNB ) |
---|
| 970 | I1 = 1 |
---|
| 971 | DO 100 I=1,MIN0(LNB/2+1,MAXX) |
---|
| 972 | CALL CH2FLT ( C, I1, LNB, N1, N2, X(I), IFLAG, NDIAG, IOU ) |
---|
| 973 | IF( IFLAG .GT. 0 ) THEN |
---|
| 974 | NX = NX + 1 |
---|
| 975 | I1 = N2 + 1 |
---|
| 976 | ELSE |
---|
| 977 | GO TO 110 |
---|
| 978 | ENDIF |
---|
| 979 | 100 CONTINUE |
---|
| 980 | 110 CONTINUE |
---|
| 981 | RETURN |
---|
| 982 | END |
---|
| 983 | SUBROUTINE FRSTNB ( C, N, NB1 ) |
---|
| 984 | C |
---|
| 985 | C Subroutine to determine the location of the last non-blank character |
---|
| 986 | C in the string C. |
---|
| 987 | C This routine assumes the character string C is blank-filled, which |
---|
| 988 | C is not the case for strings read with the VAX Q-format--they are |
---|
| 989 | C null-filled. |
---|
| 990 | C |
---|
| 991 | CHARACTER*(*) C |
---|
| 992 | C |
---|
| 993 | NB1 = 0 |
---|
| 994 | DO 20 I=1,N |
---|
| 995 | IF( C(I:I) .NE. ' ' ) THEN |
---|
| 996 | NB1 = I |
---|
| 997 | GO TO 22 |
---|
| 998 | ENDIF |
---|
| 999 | 20 CONTINUE |
---|
| 1000 | 22 CONTINUE |
---|
| 1001 | RETURN |
---|
| 1002 | END |
---|
| 1003 | SUBROUTINE L3CVAL ( X, LX, NVAL, CVAL ) |
---|
| 1004 | C |
---|
| 1005 | C Subroutine to store the last three values of character variable X, |
---|
| 1006 | C of length LX, in the array CVAL. |
---|
| 1007 | C |
---|
| 1008 | CHARACTER*(*) CVAL( * ) |
---|
| 1009 | CHARACTER*(*) X |
---|
| 1010 | C |
---|
| 1011 | IF( NVAL .GT. 3 ) THEN |
---|
| 1012 | CVAL(1) = CVAL(2)(1:LX) |
---|
| 1013 | CVAL(2) = CVAL(3)(1:LX) |
---|
| 1014 | CVAL(3) = X(1:LX) |
---|
| 1015 | ELSE |
---|
| 1016 | CVAL(NVAL) = X(1:LX) |
---|
| 1017 | ENDIF |
---|
| 1018 | RETURN |
---|
| 1019 | END |
---|
| 1020 | SUBROUTINE L3RVAL ( X, NVAL, RVAL, X0 ) |
---|
| 1021 | C |
---|
| 1022 | C Subroutine to store the last three values of real variable X |
---|
| 1023 | C in the array RVAL. |
---|
| 1024 | C |
---|
| 1025 | DIMENSION RVAL( * ) |
---|
| 1026 | C |
---|
| 1027 | IF( NVAL .GT. 3 ) THEN |
---|
| 1028 | RVAL(1) = RVAL(2) |
---|
| 1029 | RVAL(2) = RVAL(3) |
---|
| 1030 | RVAL(3) = X |
---|
| 1031 | ELSE |
---|
| 1032 | RVAL(NVAL) = X |
---|
| 1033 | X0 = RVAL(1) |
---|
| 1034 | ENDIF |
---|
| 1035 | RETURN |
---|
| 1036 | END |
---|
| 1037 | SUBROUTINE LASTNB ( C, N, LNB ) |
---|
| 1038 | C |
---|
| 1039 | C Subroutine to determine the location of the last non-blank character |
---|
| 1040 | C in the string C. |
---|
| 1041 | C This routine assumes the character string C is blank-filled, which |
---|
| 1042 | C is not the case for strings read with the VAX Q-format--they are |
---|
| 1043 | C null-filled. |
---|
| 1044 | C |
---|
| 1045 | CHARACTER*(*) C |
---|
| 1046 | C |
---|
| 1047 | LNB = 0 |
---|
| 1048 | DO 20 I=N,1,-1 |
---|
| 1049 | IF( C(I:I) .NE. ' ' ) THEN |
---|
| 1050 | LNB = I |
---|
| 1051 | GO TO 22 |
---|
| 1052 | ENDIF |
---|
| 1053 | 20 CONTINUE |
---|
| 1054 | 22 CONTINUE |
---|
| 1055 | RETURN |
---|
| 1056 | END |
---|
| 1057 | SUBROUTINE PARDAT ( V, NWANT, NFIND, SUBFLG, NSF, VALFLG, NVF, |
---|
| 1058 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1059 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1060 | C |
---|
| 1061 | C Subroutine to read numeric values, flag non-numeric characters, |
---|
| 1062 | C and flag lines with more data than expected. |
---|
| 1063 | C This routine allows for records spanning more than one line. |
---|
| 1064 | C |
---|
| 1065 | C Required routines: PARFLT. |
---|
| 1066 | C |
---|
| 1067 | CHARACTER*(*) CDUM |
---|
| 1068 | CHARACTER*(*) CRFMT |
---|
| 1069 | CHARACTER*(*) SUBFLG |
---|
| 1070 | CHARACTER*(*) VALFLG |
---|
| 1071 | C |
---|
| 1072 | DIMENSION V( * ) |
---|
| 1073 | C |
---|
| 1074 | NREAD = 0 |
---|
| 1075 | NFIND = 0 |
---|
| 1076 | I1 = 1 |
---|
| 1077 | DO 40 K=1,NWANT |
---|
| 1078 | READ ( IUN,FMT=CRFMT,IOSTAT=IERR ) CDUM |
---|
| 1079 | IF( IERR .LT. 0 ) THEN |
---|
| 1080 | IERR = -1 |
---|
| 1081 | RETURN |
---|
| 1082 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1083 | WRITE( IOU,* ) ' ***PARDAT error reading line ', LINE+1 |
---|
| 1084 | WRITE(IOU,*) ' while reading ', VALFLG(1:NVF) |
---|
| 1085 | WRITE( IOU,* ) ' PARDAT called by ',SUBFLG(1:NSF) |
---|
| 1086 | WRITE( IOU,* ) ' IOSTAT=', IERR |
---|
| 1087 | IERR = 1 |
---|
| 1088 | NDIAG = NDIAG + 1 |
---|
| 1089 | RETURN |
---|
| 1090 | ENDIF |
---|
| 1091 | LINE = LINE + 1 |
---|
| 1092 | NREAD = NREAD + 1 |
---|
| 1093 | CALL PARFLT ( CDUM, V(I1), NVAL, NWANT+5, LN, NCIDR, NBIDR, |
---|
| 1094 | * NEXTRA, NDIAG, IOU ) |
---|
| 1095 | NFIND = NFIND + NVAL |
---|
| 1096 | IF( NEXTRA .GT. 0 ) THEN |
---|
| 1097 | WRITE(IOU,*) |
---|
| 1098 | * ' **PARDAT found extraneous character in line ', LINE |
---|
| 1099 | WRITE(IOU,*) ' Number of extraneous chars.= ', NEXTRA |
---|
| 1100 | WRITE( IOU,* ) ' PARDAT called by ',SUBFLG(1:NSF) |
---|
| 1101 | NDIAG = NDIAG + 1 |
---|
| 1102 | ENDIF |
---|
| 1103 | IF( NFIND .EQ. NWANT ) THEN |
---|
| 1104 | GOTO 42 |
---|
| 1105 | ELSE IF( NFIND .GT. NWANT ) THEN |
---|
| 1106 | WRITE(IOU,*) |
---|
| 1107 | * ' **PARDAT error--excess values in line ', LINE |
---|
| 1108 | WRITE(IOU,*) ' while reading ', VALFLG(1:NVF) |
---|
| 1109 | WRITE(IOU,*) ' PARDAT called by ',SUBFLG(1:NSF) |
---|
| 1110 | NDIAG = NDIAG + 1 |
---|
| 1111 | GOTO 42 |
---|
| 1112 | ELSE IF( NVAL .LT. 1 ) THEN |
---|
| 1113 | WRITE(IOU,*) ' **PARDAT error--no numbers in line ',LINE |
---|
| 1114 | WRITE(IOU,*) ' while reading ', VALFLG(1:NVF) |
---|
| 1115 | WRITE(IOU,*) ' PARDAT called by ',SUBFLG(1:NSF) |
---|
| 1116 | NDIAG = NDIAG + 1 |
---|
| 1117 | ENDIF |
---|
| 1118 | I1 = NFIND + 1 |
---|
| 1119 | 40 CONTINUE |
---|
| 1120 | 42 CONTINUE |
---|
| 1121 | RETURN |
---|
| 1122 | END |
---|
| 1123 | SUBROUTINE PARFLT ( C, X, NX, MAXX, LN, NCIDR, NBIDR, NEXTRA, |
---|
| 1124 | * NDIAG, IOU ) |
---|
| 1125 | C |
---|
| 1126 | C Subroutine to find MAXX floating point numbers (integers included) |
---|
| 1127 | C in a character string C(1:LN), and flag non-numeric characters in |
---|
| 1128 | C the string. |
---|
| 1129 | C This routine also keeps a running talley of the number of characters |
---|
| 1130 | C (NCIDR) and the number of blanks (NBIDR) in C(1:LN). |
---|
| 1131 | C |
---|
| 1132 | C History: |
---|
| 1133 | C 92-02-11 - Modified to check for blank space between numeric |
---|
| 1134 | C values. |
---|
| 1135 | C 91-12-17 - Modified to stop searching for numbers if NX=MAXX, and |
---|
| 1136 | C to return the index of either the last numeric character |
---|
| 1137 | C in the string (if NX=MAXX) or the last nonblank |
---|
| 1138 | C character in the string (if NX<MAXX). |
---|
| 1139 | C |
---|
| 1140 | C |
---|
| 1141 | C Required routines: CH2FLT, CHFMT, CNTBLA, LASTNB |
---|
| 1142 | C |
---|
| 1143 | CHARACTER*(*) C |
---|
| 1144 | CHARACTER*6 CWFMT |
---|
| 1145 | C |
---|
| 1146 | DIMENSION X( * ) |
---|
| 1147 | C |
---|
| 1148 | NX = 0 |
---|
| 1149 | NC = 0 |
---|
| 1150 | NS = 0 |
---|
| 1151 | CALL LASTNB ( C, LEN(C), LNB ) |
---|
| 1152 | NCIDR = NCIDR + LNB |
---|
| 1153 | I1 = 1 |
---|
| 1154 | I = 0 |
---|
| 1155 | 30 CONTINUE |
---|
| 1156 | I = I + 1 |
---|
| 1157 | CALL CH2FLT ( C, I1, LNB, N1, N2, X(I), IFLAG, NDIAG, IOU ) |
---|
| 1158 | IF( IFLAG .GT. 0 ) THEN |
---|
| 1159 | NX = NX + 1 |
---|
| 1160 | IF( N1 .GT. 1 ) THEN |
---|
| 1161 | IF( C(N1-1:N1-1) .NE. ' ' ) NS = NS + 1 |
---|
| 1162 | ENDIF |
---|
| 1163 | I1 = N2 + 1 |
---|
| 1164 | NC = NC + N2 - N1 + 1 |
---|
| 1165 | LN = N2 |
---|
| 1166 | IF( NX .EQ. MAXX ) GOTO 110 |
---|
| 1167 | ELSE |
---|
| 1168 | LN = LNB |
---|
| 1169 | GO TO 110 |
---|
| 1170 | ENDIF |
---|
| 1171 | IF( I1 .LT. LNB ) GOTO 30 |
---|
| 1172 | 110 CONTINUE |
---|
| 1173 | CALL CNTBLA ( C, 1, LN, NBLANK ) |
---|
| 1174 | NBIDR = NBIDR + NBLANK |
---|
| 1175 | NEXTRA = LN - NC - NBLANK |
---|
| 1176 | IF( NS .GT. 0 ) THEN |
---|
| 1177 | WRITE(IOU,*) |
---|
| 1178 | * ' **PARFLT error--The following line contains values with ' |
---|
| 1179 | WRITE(IOU,*) ' no space between them:' |
---|
| 1180 | CALL CHFMT ( LNB, CWFMT ) |
---|
| 1181 | WRITE(IOU,FMT=CWFMT) C(1:LNB) |
---|
| 1182 | NDIAG = NDIAG + 1 |
---|
| 1183 | ENDIF |
---|
| 1184 | RETURN |
---|
| 1185 | END |
---|
| 1186 | SUBROUTINE PARHD ( V, NWANT, NFIND, SUBFLG, NSF, VALFLG, NVF, |
---|
| 1187 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1188 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1189 | C |
---|
| 1190 | C Subroutine to read numeric values from file header records and |
---|
| 1191 | C flag non-numeric characters within the fields where they should |
---|
| 1192 | C not be. |
---|
| 1193 | C This routine is essentially the same as PARDAT except that it |
---|
| 1194 | C forces PARFLT to stop reading after it finds NWANT characters. |
---|
| 1195 | C This behavior is to allow for the possibility of comments in the |
---|
| 1196 | C file header records. |
---|
| 1197 | C This routine allows for records spanning more than one line. |
---|
| 1198 | C |
---|
| 1199 | C Required routines: PARFLT. |
---|
| 1200 | C |
---|
| 1201 | CHARACTER*(*) CDUM |
---|
| 1202 | CHARACTER*(*) CRFMT |
---|
| 1203 | CHARACTER*(*) SUBFLG |
---|
| 1204 | CHARACTER*(*) VALFLG |
---|
| 1205 | C |
---|
| 1206 | DIMENSION V( * ) |
---|
| 1207 | C |
---|
| 1208 | NREAD = 0 |
---|
| 1209 | NFIND = 0 |
---|
| 1210 | I1 = 1 |
---|
| 1211 | DO 40 K=1,NWANT |
---|
| 1212 | READ ( IUN,FMT=CRFMT,IOSTAT=IERR ) CDUM |
---|
| 1213 | IF( IERR .LT. 0 ) THEN |
---|
| 1214 | IERR = -1 |
---|
| 1215 | RETURN |
---|
| 1216 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1217 | WRITE( IOU,* ) ' ***PARHD error reading line ', LINE+1 |
---|
| 1218 | WRITE(IOU,*) ' while reading ', VALFLG(1:NVF) |
---|
| 1219 | WRITE( IOU,* ) ' PARHD called by ',SUBFLG(1:NSF) |
---|
| 1220 | WRITE( IOU,* ) ' IOSTAT=', IERR |
---|
| 1221 | IERR = 1 |
---|
| 1222 | NDIAG = NDIAG + 1 |
---|
| 1223 | RETURN |
---|
| 1224 | ENDIF |
---|
| 1225 | LINE = LINE + 1 |
---|
| 1226 | NREAD = NREAD + 1 |
---|
| 1227 | CALL PARFLT ( CDUM, V(I1), NVAL, NWANT, LN, NCIDR, NBIDR, |
---|
| 1228 | * NEXTRA, NDIAG, IOU ) |
---|
| 1229 | NFIND = NFIND + NVAL |
---|
| 1230 | IF( NEXTRA .GT. 0 ) THEN |
---|
| 1231 | WRITE(IOU,*) |
---|
| 1232 | * ' **PARHD found extraneous character in line ', LINE |
---|
| 1233 | WRITE(IOU,*) ' Number of extraneous chars.= ', NEXTRA |
---|
| 1234 | WRITE( IOU,* ) ' PARHD called by ',SUBFLG(1:NSF) |
---|
| 1235 | NDIAG = NDIAG + 1 |
---|
| 1236 | ENDIF |
---|
| 1237 | IF( NFIND .EQ. NWANT ) THEN |
---|
| 1238 | GOTO 42 |
---|
| 1239 | ELSE IF( NVAL .LT. 1 ) THEN |
---|
| 1240 | WRITE(IOU,*) ' **PARHD error--no numbers in line ',LINE |
---|
| 1241 | WRITE(IOU,*) ' while reading ', VALFLG(1:NVF) |
---|
| 1242 | WRITE(IOU,*) ' PARHD called by ',SUBFLG(1:NSF) |
---|
| 1243 | NDIAG = NDIAG + 1 |
---|
| 1244 | ENDIF |
---|
| 1245 | I1 = NFIND + 1 |
---|
| 1246 | 40 CONTINUE |
---|
| 1247 | IF( NFIND .LT. NWANT ) THEN |
---|
| 1248 | WRITE(IOU,*) ' ***PARHD could not find all values of ', |
---|
| 1249 | * VALFLG(1:NVF) |
---|
| 1250 | WRITE(IOU,*) ' Started looking at line ',LINE-NREAD+1 |
---|
| 1251 | WRITE(IOU,*) ' Number of values to find= ', NWANT |
---|
| 1252 | NDIAG = NDIAG + 1 |
---|
| 1253 | IERR = 2 |
---|
| 1254 | ENDIF |
---|
| 1255 | 42 CONTINUE |
---|
| 1256 | RETURN |
---|
| 1257 | END |
---|
| 1258 | SUBROUTINE PD1001 ( X1, V, VMISS, NV, CDUM, DUM, |
---|
| 1259 | * LINE, NCIDR, NBIDR, NVALS, |
---|
| 1260 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1261 | C |
---|
| 1262 | C Subroutine to read a data record for FFI=1001. |
---|
| 1263 | C This routine reads the expected number of values, checks for extra |
---|
| 1264 | C values within the record, tests dependent variables against their |
---|
| 1265 | C missing values, and counts the number of lines, number of characters, |
---|
| 1266 | C and the number of blanks in the data records. |
---|
| 1267 | C |
---|
| 1268 | C IERR = 0 = successful read. |
---|
| 1269 | C = -1 = EOF encountered. |
---|
| 1270 | C = +1 = read error. |
---|
| 1271 | C |
---|
| 1272 | C Required routines: CKMISV, PARDAT. |
---|
| 1273 | C |
---|
| 1274 | C |
---|
| 1275 | CHARACTER*(*) CDUM |
---|
| 1276 | CHARACTER*(*) CRFMT |
---|
| 1277 | C |
---|
| 1278 | DIMENSION DUM( * ), V( * ), VMISS( * ) |
---|
| 1279 | C |
---|
| 1280 | IERR = 0 |
---|
| 1281 | CALL PARDAT ( DUM, NV+1, NFIND, 'PD1001', 6, 'X1,V(N)', 7, |
---|
| 1282 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1283 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1284 | NVALS = NVALS + NFIND |
---|
| 1285 | IF( IERR .LT. 0 ) THEN |
---|
| 1286 | GOTO 100 |
---|
| 1287 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1288 | RETURN |
---|
| 1289 | ELSE |
---|
| 1290 | X1 = DUM(1) |
---|
| 1291 | DO 30 N=1,NV |
---|
| 1292 | V(N) = DUM(N+1) |
---|
| 1293 | 30 CONTINUE |
---|
| 1294 | CALL CKMISV ( V, VMISS, NV, X1, |
---|
| 1295 | * 'V(N)', 4, 'X1', 2, 'PD1001', 6, NDIAG, IOU ) |
---|
| 1296 | ENDIF |
---|
| 1297 | RETURN |
---|
| 1298 | C |
---|
| 1299 | C Flag EOF. |
---|
| 1300 | C |
---|
| 1301 | 100 CONTINUE |
---|
| 1302 | IF( NFIND .GT. 0 .AND. NFIND .LT. NV+1 ) THEN |
---|
| 1303 | WRITE( IOU,* ) ' ***PD1001 error--premature EOF in line',LINE+1 |
---|
| 1304 | WRITE( IOU,* ) ' while reading X1,V(N)' |
---|
| 1305 | WRITE( IOU,* ) ' Last successfully read value of X1=', X1 |
---|
| 1306 | WRITE( IOU,* ) ' Number of values expected in record=',NV+1 |
---|
| 1307 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1308 | NDIAG = NDIAG + 1 |
---|
| 1309 | ENDIF |
---|
| 1310 | RETURN |
---|
| 1311 | END |
---|
| 1312 | SUBROUTINE PD1010 ( X1, A, AMISS, NAUXV, V, VMISS, NV, |
---|
| 1313 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 1314 | * IUN, IOU, NDIAG, IERR ) |
---|
| 1315 | C |
---|
| 1316 | C Subroutine to read a data record group for FFI=1010. |
---|
| 1317 | C This routine reads the expected number of values, checks for extra |
---|
| 1318 | C values within the record, tests dependent variables against their |
---|
| 1319 | C missing values, and counts the number of lines, number of characters, |
---|
| 1320 | C and the number of blanks in the data records. |
---|
| 1321 | C |
---|
| 1322 | C IERR = 0 = successful read. |
---|
| 1323 | C = -1 = EOF encountered. |
---|
| 1324 | C = +1 = read error. |
---|
| 1325 | C |
---|
| 1326 | C Required routines: CKMISV, PARDAT. |
---|
| 1327 | C |
---|
| 1328 | C |
---|
| 1329 | CHARACTER*(*) CDUM |
---|
| 1330 | CHARACTER*(*) CRFMT |
---|
| 1331 | C |
---|
| 1332 | DIMENSION A( * ), AMISS( * ), DUM( * ), V( * ), VMISS( * ) |
---|
| 1333 | C |
---|
| 1334 | IERR = 0 |
---|
| 1335 | C |
---|
| 1336 | C Read a group of data records. |
---|
| 1337 | C |
---|
| 1338 | CALL PARDAT ( DUM, NAUXV+1, NFIND, 'PD1010', 6, 'X1,A(I)', 7, |
---|
| 1339 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1340 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1341 | NVALS = NVALS + NFIND |
---|
| 1342 | IF( IERR .LT. 0 ) THEN |
---|
| 1343 | GOTO 100 |
---|
| 1344 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1345 | RETURN |
---|
| 1346 | ELSE |
---|
| 1347 | X1 = DUM(1) |
---|
| 1348 | IF( NAUXV .GT. 0 ) THEN |
---|
| 1349 | DO 30 IA=1,NAUXV |
---|
| 1350 | A(IA) = DUM(IA+1) |
---|
| 1351 | 30 CONTINUE |
---|
| 1352 | CALL CKMISV ( A, AMISS, NAUXV, X1, |
---|
| 1353 | * 'A(I)', 4, 'X1', 2, 'PD1010', 6, NDIAG, IOU ) |
---|
| 1354 | ENDIF |
---|
| 1355 | ENDIF |
---|
| 1356 | CALL PARDAT ( DUM, NV, NFIND, 'PD1010', 6, 'V(N)', 4, |
---|
| 1357 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1358 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1359 | NVALS = NVALS + NFIND |
---|
| 1360 | IF( IERR .LT. 0 ) THEN |
---|
| 1361 | GOTO 102 |
---|
| 1362 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1363 | RETURN |
---|
| 1364 | ELSE |
---|
| 1365 | DO 40 N=1,NV |
---|
| 1366 | V(N) = DUM(N) |
---|
| 1367 | 40 CONTINUE |
---|
| 1368 | CALL CKMISV ( V, VMISS, NV, X1, |
---|
| 1369 | * 'V(N)', 4, 'X1', 2, 'PD1010', 6, NDIAG, IOU ) |
---|
| 1370 | ENDIF |
---|
| 1371 | RETURN |
---|
| 1372 | C |
---|
| 1373 | C Flag EOF. |
---|
| 1374 | C |
---|
| 1375 | 100 CONTINUE |
---|
| 1376 | IF( NFIND .GT. 0 .AND. NFIND .LT. NAUXV+1 ) THEN |
---|
| 1377 | WRITE( IOU,* ) ' ***PD1010 error--premature EOF in line',LINE+1 |
---|
| 1378 | WRITE( IOU,* ) ' while reading X1,A(I)' |
---|
| 1379 | WRITE( IOU,* ) ' Last successfully read value of X1=', X1 |
---|
| 1380 | WRITE( IOU,* ) ' Number of values expected in record=', |
---|
| 1381 | * NAUXV+1 |
---|
| 1382 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1383 | NDIAG = NDIAG + 1 |
---|
| 1384 | ENDIF |
---|
| 1385 | RETURN |
---|
| 1386 | 102 CONTINUE |
---|
| 1387 | WRITE( IOU,* ) ' ***PD1010 error--premature EOF in line',LINE+1 |
---|
| 1388 | WRITE( IOU,* ) ' while reading primary variables' |
---|
| 1389 | WRITE( IOU,* ) ' Incomplete primary variable list at X1=',X1 |
---|
| 1390 | WRITE( IOU,* ) ' Number of values expected in record=', NV |
---|
| 1391 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1392 | NDIAG = NDIAG + 1 |
---|
| 1393 | RETURN |
---|
| 1394 | END |
---|
| 1395 | SUBROUTINE PD1020 ( X1, DX, A, AMISS, NAUXV, |
---|
| 1396 | * V, VMISS, MAXX1, NVPM, NV, |
---|
| 1397 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 1398 | * IUN, IOU, NDIAG, IERR ) |
---|
| 1399 | C |
---|
| 1400 | C Subroutine to read a data record group for FFI=1020. |
---|
| 1401 | C This routine reads the expected number of values, checks for extra |
---|
| 1402 | C values within the record, tests dependent variables against their |
---|
| 1403 | C missing values, and counts the number of lines, number of characters, |
---|
| 1404 | C and the number of blanks in the data records. |
---|
| 1405 | C |
---|
| 1406 | C IERR = 0 = successful read. |
---|
| 1407 | C = -1 = EOF encountered. |
---|
| 1408 | C = +1 = read error. |
---|
| 1409 | C |
---|
| 1410 | C Required routines: CKMISV, CKMSXV, PARDAT. |
---|
| 1411 | C |
---|
| 1412 | C |
---|
| 1413 | CHARACTER*(*) CDUM |
---|
| 1414 | CHARACTER*(*) CRFMT |
---|
| 1415 | C |
---|
| 1416 | DIMENSION A( * ), AMISS( * ), DUM( * ) |
---|
| 1417 | DIMENSION V( MAXX1,* ), VMISS( * ), X1( * ) |
---|
| 1418 | C |
---|
| 1419 | IERR = 0 |
---|
| 1420 | C |
---|
| 1421 | C Read a group of data records. |
---|
| 1422 | C |
---|
| 1423 | CALL PARDAT ( DUM, NAUXV+1, NFIND, 'PD1020', 6, 'X1,A(I)', 7, |
---|
| 1424 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1425 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1426 | NVALS = NVALS + NFIND |
---|
| 1427 | IF( IERR .LT. 0 ) THEN |
---|
| 1428 | GOTO 100 |
---|
| 1429 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1430 | RETURN |
---|
| 1431 | ELSE |
---|
| 1432 | X1(1) = DUM(1) |
---|
| 1433 | IF( NAUXV .GT. 0 ) THEN |
---|
| 1434 | DO 20 IA=1,NAUXV |
---|
| 1435 | A(IA) = DUM(IA+1) |
---|
| 1436 | 20 CONTINUE |
---|
| 1437 | CALL CKMISV ( A, AMISS, NAUXV, X1, |
---|
| 1438 | * 'A(I)', 4, 'X1', 2, 'PD1020', 6, NDIAG, IOU ) |
---|
| 1439 | ENDIF |
---|
| 1440 | ENDIF |
---|
| 1441 | C |
---|
| 1442 | DO 30 N=1,NV |
---|
| 1443 | CALL PARDAT ( DUM, NVPM, NFIND, 'PD1020', 6, 'V(I,N)', 6, |
---|
| 1444 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1445 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1446 | NVALS = NVALS + NFIND |
---|
| 1447 | IF( IERR .LT. 0 ) THEN |
---|
| 1448 | GOTO 102 |
---|
| 1449 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1450 | RETURN |
---|
| 1451 | ELSE |
---|
| 1452 | DO 26 I=1,NVPM |
---|
| 1453 | V(I,N) = DUM(I) |
---|
| 1454 | 26 CONTINUE |
---|
| 1455 | ENDIF |
---|
| 1456 | 30 CONTINUE |
---|
| 1457 | CALL CKMSXV ( V, MAXX1, VMISS, NV, X1, NVPM, |
---|
| 1458 | * 'V(N)', 4, 'X1', 2, 'PD1020', 6, NDIAG, IOU ) |
---|
| 1459 | C |
---|
| 1460 | C Define X1 values. |
---|
| 1461 | C |
---|
| 1462 | DO 40 I=2,NVPM |
---|
| 1463 | X1(I) = X1(1) + DX * FLOAT( I-1 ) |
---|
| 1464 | 40 CONTINUE |
---|
| 1465 | RETURN |
---|
| 1466 | C |
---|
| 1467 | C Flag EOF. |
---|
| 1468 | C |
---|
| 1469 | 100 CONTINUE |
---|
| 1470 | IF( NFIND .GT. 0 .AND. NFIND .LT. NAUXV+1 ) THEN |
---|
| 1471 | WRITE( IOU,* ) ' ***PD1020 error--premature EOF in line',LINE+1 |
---|
| 1472 | WRITE( IOU,* ) ' while reading X1,A(I)' |
---|
| 1473 | WRITE( IOU,* ) ' Last successfully read value of X1=', X1(1) |
---|
| 1474 | WRITE( IOU,* ) ' Number of values expected in record=', |
---|
| 1475 | * NAUXV+1 |
---|
| 1476 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1477 | NDIAG = NDIAG + 1 |
---|
| 1478 | ENDIF |
---|
| 1479 | RETURN |
---|
| 1480 | 102 CONTINUE |
---|
| 1481 | WRITE( IOU,* ) ' ***PD1010 error--premature EOF while reading' |
---|
| 1482 | WRITE( IOU,* ) ' values of primary variable V(I,N), N=',N |
---|
| 1483 | WRITE( IOU,* ) ' at independent variable mark X1(1)=', X1(1) |
---|
| 1484 | WRITE( IOU,* ) ' NV, NVPM=', NV, NVPM |
---|
| 1485 | WRITE( IOU,* ) ' Number of values expected in record=',NVPM |
---|
| 1486 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1487 | NDIAG = NDIAG + 1 |
---|
| 1488 | RETURN |
---|
| 1489 | END |
---|
| 1490 | SUBROUTINE PD2010 ( X2, A, AMISS, NAUXV, V, VMISS, MAXX1, NX, NV, |
---|
| 1491 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 1492 | * IUN, IOU, NDIAG, IERR ) |
---|
| 1493 | C |
---|
| 1494 | C Subroutine to read a data record group for FFI=2010. |
---|
| 1495 | C This routine reads the expected number of values, checks for extra |
---|
| 1496 | C values within the record, tests dependent variables against their |
---|
| 1497 | C missing values, and counts the number of lines, number of characters, |
---|
| 1498 | C and the number of blanks in the data records. |
---|
| 1499 | C |
---|
| 1500 | C IERR = 0 = successful read. |
---|
| 1501 | C = -1 = EOF encountered. |
---|
| 1502 | C = +1 = read error. |
---|
| 1503 | C |
---|
| 1504 | C Required routines: CKMISV, CKMSXV, PARDAT. |
---|
| 1505 | C |
---|
| 1506 | C |
---|
| 1507 | CHARACTER*(*) CDUM |
---|
| 1508 | CHARACTER*(*) CRFMT |
---|
| 1509 | C |
---|
| 1510 | DIMENSION A( * ), AMISS( * ), DUM( * ) |
---|
| 1511 | DIMENSION V( MAXX1,* ), VMISS( * ) |
---|
| 1512 | C |
---|
| 1513 | IERR = 0 |
---|
| 1514 | C |
---|
| 1515 | C Read a group of data records. |
---|
| 1516 | C |
---|
| 1517 | CALL PARDAT ( DUM, NAUXV+1, NFIND, 'PD2010', 6, 'X2,A(I)', 7, |
---|
| 1518 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1519 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1520 | NVALS = NVALS + NFIND |
---|
| 1521 | IF( IERR .LT. 0 ) THEN |
---|
| 1522 | GOTO 100 |
---|
| 1523 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1524 | RETURN |
---|
| 1525 | ELSE |
---|
| 1526 | X2 = DUM(1) |
---|
| 1527 | IF( NAUXV .GT. 0 ) THEN |
---|
| 1528 | DO 20 IA=1,NAUXV |
---|
| 1529 | A(IA) = DUM(IA+1) |
---|
| 1530 | 20 CONTINUE |
---|
| 1531 | CALL CKMISV ( A, AMISS, NAUXV, X2, |
---|
| 1532 | * 'A(I)', 4, 'X2', 2, 'PD2010', 6, NDIAG, IOU ) |
---|
| 1533 | ENDIF |
---|
| 1534 | ENDIF |
---|
| 1535 | C |
---|
| 1536 | DO 30 N=1,NV |
---|
| 1537 | CALL PARDAT ( DUM, NX, NFIND, 'PD2010', 6, 'V(I,N)', 6, |
---|
| 1538 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1539 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1540 | NVALS = NVALS + NFIND |
---|
| 1541 | IF( IERR .LT. 0 ) THEN |
---|
| 1542 | GOTO 102 |
---|
| 1543 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1544 | RETURN |
---|
| 1545 | ELSE |
---|
| 1546 | DO 26 I=1,NX |
---|
| 1547 | V(I,N) = DUM(I) |
---|
| 1548 | 26 CONTINUE |
---|
| 1549 | ENDIF |
---|
| 1550 | 30 CONTINUE |
---|
| 1551 | C |
---|
| 1552 | CALL CKMSXV ( V, MAXX1, VMISS, NV, X2, NX, |
---|
| 1553 | * 'V(N)', 4, 'X2', 2, 'PD2010', 6, NDIAG, IOU ) |
---|
| 1554 | RETURN |
---|
| 1555 | C |
---|
| 1556 | C Flag EOF. |
---|
| 1557 | C |
---|
| 1558 | 100 CONTINUE |
---|
| 1559 | IF( NFIND .GT. 0 .AND. NFIND .LT. NAUXV+1 ) THEN |
---|
| 1560 | WRITE( IOU,* ) ' ***PD2010 error--premature EOF in line',LINE+1 |
---|
| 1561 | WRITE( IOU,* ) ' while reading X2,A(I)' |
---|
| 1562 | WRITE( IOU,* ) ' Last successfully read value of X2=', X2 |
---|
| 1563 | WRITE( IOU,* ) ' Number of values expected in record=', |
---|
| 1564 | * NAUXV+1 |
---|
| 1565 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1566 | NDIAG = NDIAG + 1 |
---|
| 1567 | ENDIF |
---|
| 1568 | RETURN |
---|
| 1569 | 102 CONTINUE |
---|
| 1570 | WRITE( IOU,* ) ' ***PD2010 encountered EOF while reading values' |
---|
| 1571 | WRITE( IOU,* ) ' of primary variable V(I,N), N=', N |
---|
| 1572 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 1573 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 1574 | WRITE( IOU,* ) ' Number of values expected in record=', NX |
---|
| 1575 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1576 | NDIAG = NDIAG + 1 |
---|
| 1577 | RETURN |
---|
| 1578 | END |
---|
| 1579 | SUBROUTINE PD2110 ( X1, X2, A, AMISS, NAUXV, V, VMISS, MAXX1, |
---|
| 1580 | * NX, NV, CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, |
---|
| 1581 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1582 | C |
---|
| 1583 | C Subroutine to read a data record group for FFI=2110. |
---|
| 1584 | C This routine reads the expected number of values, checks for extra |
---|
| 1585 | C values within the record, tests dependent variables against their |
---|
| 1586 | C missing values, and counts the number of lines, number of characters, |
---|
| 1587 | C and the number of blanks in the data records. |
---|
| 1588 | C |
---|
| 1589 | C IERR = 0 = successful read. |
---|
| 1590 | C = -1 = EOF encountered. |
---|
| 1591 | C = +1 = read error. |
---|
| 1592 | C = +2 = error in value of NX |
---|
| 1593 | C |
---|
| 1594 | C Required routines: CKMISV, CKMSXV, PARDAT. |
---|
| 1595 | C |
---|
| 1596 | C |
---|
| 1597 | CHARACTER*(*) CDUM |
---|
| 1598 | CHARACTER*(*) CRFMT |
---|
| 1599 | C |
---|
| 1600 | DIMENSION A( * ), AMISS( * ), DUM( * ) |
---|
| 1601 | DIMENSION V( MAXX1,* ), VMISS( * ), X1( * ) |
---|
| 1602 | C |
---|
| 1603 | IERR = 0 |
---|
| 1604 | C |
---|
| 1605 | C Read a group of data records. |
---|
| 1606 | C |
---|
| 1607 | CALL PARDAT ( DUM, NAUXV+1, NFIND, 'PD2110', 6, 'X2,A(I)', 7, |
---|
| 1608 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1609 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1610 | NVALS = NVALS + NFIND |
---|
| 1611 | IF( IERR .LT. 0 ) THEN |
---|
| 1612 | GOTO 100 |
---|
| 1613 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1614 | RETURN |
---|
| 1615 | ELSE |
---|
| 1616 | X2 = DUM(1) |
---|
| 1617 | NX = INT( DUM(2) + 0.5 ) |
---|
| 1618 | IF( NX .GT. MAXX1 .AND. NX .NE. INT(AMISS(1)+0.5) ) THEN |
---|
| 1619 | WRITE( IOU,* ) ' ***PD2110 error--NX(1) too large' |
---|
| 1620 | WRITE( IOU,* ) ' MAXX1,NX(1)=', MAXX1, NX |
---|
| 1621 | IERR = 2 |
---|
| 1622 | NDIAG = NDIAG + 1 |
---|
| 1623 | RETURN |
---|
| 1624 | ENDIF |
---|
| 1625 | DO 20 IA=1,NAUXV |
---|
| 1626 | A(IA) = DUM(IA+1) |
---|
| 1627 | 20 CONTINUE |
---|
| 1628 | CALL CKMISV ( A, AMISS, NAUXV, X2, |
---|
| 1629 | * 'A(I)', 4, 'X2', 2, 'PD2110', 6, NDIAG, IOU ) |
---|
| 1630 | ENDIF |
---|
| 1631 | C |
---|
| 1632 | IF( NX .GT. 0 .AND. NX .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 1633 | DO 30 I=1,NX |
---|
| 1634 | CALL PARDAT ( DUM, NV+1, NFIND, 'PD2110', 6, |
---|
| 1635 | * 'X1(I),V(I,N)', 12, |
---|
| 1636 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1637 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1638 | NVALS = NVALS + NFIND |
---|
| 1639 | IF( IERR .LT. 0 ) THEN |
---|
| 1640 | GOTO 102 |
---|
| 1641 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1642 | RETURN |
---|
| 1643 | ELSE |
---|
| 1644 | X1(I) = DUM(1) |
---|
| 1645 | DO 26 N=1,NV |
---|
| 1646 | V(I,N) = DUM(N+1) |
---|
| 1647 | 26 CONTINUE |
---|
| 1648 | ENDIF |
---|
| 1649 | 30 CONTINUE |
---|
| 1650 | CALL CKMSXV ( V, MAXX1, VMISS, NV, X2, NX, 'X1(I),V(I,N)', 12, |
---|
| 1651 | * 'X2', 2, 'PD2110', 6, NDIAG, IOU ) |
---|
| 1652 | ENDIF |
---|
| 1653 | RETURN |
---|
| 1654 | C |
---|
| 1655 | C Flag EOF. |
---|
| 1656 | C |
---|
| 1657 | 100 CONTINUE |
---|
| 1658 | IF( NFIND .GT. 0 .AND. NFIND .LT. NAUXV+1 ) THEN |
---|
| 1659 | WRITE( IOU,* ) ' ***PD2110 error--premature EOF in line',LINE+1 |
---|
| 1660 | WRITE( IOU,* ) ' while reading X2,A(I)' |
---|
| 1661 | WRITE( IOU,* ) ' Last successfully read value of X2=', X2 |
---|
| 1662 | WRITE( IOU,* ) ' Number of values expected in record=', |
---|
| 1663 | * NAUXV+1 |
---|
| 1664 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1665 | NDIAG = NDIAG + 1 |
---|
| 1666 | ENDIF |
---|
| 1667 | RETURN |
---|
| 1668 | 102 CONTINUE |
---|
| 1669 | WRITE( IOU,* ) ' ***PD2110 encountered EOF' |
---|
| 1670 | WRITE( IOU,* ) ' while reading record containing X1(I), I= ', I |
---|
| 1671 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 1672 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 1673 | WRITE( IOU,* ) ' Number of values expected in record=',NV+1 |
---|
| 1674 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1675 | NDIAG = NDIAG + 1 |
---|
| 1676 | RETURN |
---|
| 1677 | END |
---|
| 1678 | SUBROUTINE PD2160 ( X1, CX2, LENX, |
---|
| 1679 | * A, AMISS, NAUXV, CA, CAMISS, LENA, NAUXC, |
---|
| 1680 | * V, VMISS, MAXX1, NX, NV, |
---|
| 1681 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, |
---|
| 1682 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1683 | C |
---|
| 1684 | C Subroutine to read a data record group for FFI=2160. |
---|
| 1685 | C This routine reads the expected number of values, checks for extra |
---|
| 1686 | C values within the record, tests dependent variables against their |
---|
| 1687 | C missing values, and counts the number of lines, number of characters, |
---|
| 1688 | C and the number of blanks in the data records. |
---|
| 1689 | C |
---|
| 1690 | C IERR = 0 = successful read. |
---|
| 1691 | C = -1 = EOF encountered. |
---|
| 1692 | C = +1 = read error. |
---|
| 1693 | C = +2 = error in value of NX. |
---|
| 1694 | C |
---|
| 1695 | C Required routines: LASTNB, PARDAT. |
---|
| 1696 | C |
---|
| 1697 | C History: |
---|
| 1698 | C 91-10-25 (SEG) - Added code to test lengths of CX2 and CA. |
---|
| 1699 | C |
---|
| 1700 | C |
---|
| 1701 | CHARACTER*(*) CA( * ) |
---|
| 1702 | CHARACTER*(*) CAMISS( * ) |
---|
| 1703 | CHARACTER*(*) CDUM |
---|
| 1704 | CHARACTER*(*) CRFMT |
---|
| 1705 | CHARACTER*(*) CX2 |
---|
| 1706 | C |
---|
| 1707 | DIMENSION A( * ), AMISS( * ), V( MAXX1,* ), VMISS( * ) |
---|
| 1708 | DIMENSION DUM( * ), LENX( * ), LENA( * ), X1( * ) |
---|
| 1709 | C |
---|
| 1710 | IERR = 0 |
---|
| 1711 | C |
---|
| 1712 | C Read a group of data records. |
---|
| 1713 | C |
---|
| 1714 | READ( IUN,FMT=CRFMT,ERR=200,END=100 ) CX2 |
---|
| 1715 | CALL LASTNB ( CX2, LEN(CX2), LX2 ) |
---|
| 1716 | IF( LX2 .GT. LENX(2) ) THEN |
---|
| 1717 | WRITE( IOU,* ) ' **PR2160 error--string too long for' |
---|
| 1718 | WRITE( IOU,* ) ' independent variable mark X2=', CX2(1:LX2) |
---|
| 1719 | WRITE( IOU,* ) ' LENGTH, LENX= ', LX2, LENX(2) |
---|
| 1720 | NDIAG = NDIAG + 1 |
---|
| 1721 | ENDIF |
---|
| 1722 | C |
---|
| 1723 | CALL PARDAT ( DUM, NAUXV-NAUXC, NFIND, 'PD2160', 6, |
---|
| 1724 | * 'Real A(I)', 9, |
---|
| 1725 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1726 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1727 | NVALS = NVALS + NFIND |
---|
| 1728 | IF( IERR .LT. 0 ) THEN |
---|
| 1729 | GOTO 101 |
---|
| 1730 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1731 | RETURN |
---|
| 1732 | ELSE |
---|
| 1733 | NX = INT( DUM(1)+0.5 ) |
---|
| 1734 | IF( NX .GT. MAXX1 .AND. NX .NE. INT(AMISS(1)+0.5) ) THEN |
---|
| 1735 | WRITE( IOU,* ) ' ***PD2160 error--NX(1) too large' |
---|
| 1736 | WRITE( IOU,* ) ' MAXX1,NX(1)=', MAXX1, NX |
---|
| 1737 | IERR = 2 |
---|
| 1738 | NDIAG = NDIAG + 1 |
---|
| 1739 | RETURN |
---|
| 1740 | ENDIF |
---|
| 1741 | DO 16 IA=1,NAUXV-NAUXC |
---|
| 1742 | A(IA) = DUM(IA) |
---|
| 1743 | IF( A(IA) .GT. AMISS(IA) ) THEN |
---|
| 1744 | WRITE( IOU,* ) |
---|
| 1745 | * ' **PD2160 error--auxiliary variable .GT. its missing value' |
---|
| 1746 | WRITE( IOU,* ) |
---|
| 1747 | * ' at independent variable mark X2= ',CX2(1:LENX(2)) |
---|
| 1748 | WRITE( IOU,* ) |
---|
| 1749 | * ' I, A(I), AMISS(I)= ', IA,A(IA),AMISS(IA) |
---|
| 1750 | NDIAG = NDIAG + 1 |
---|
| 1751 | ENDIF |
---|
| 1752 | 16 CONTINUE |
---|
| 1753 | ENDIF |
---|
| 1754 | C |
---|
| 1755 | IF( NAUXC .GT. 0 ) THEN |
---|
| 1756 | DO 20 IC=1,NAUXC |
---|
| 1757 | READ( IUN,FMT=CRFMT,ERR=202,END=102 ) CA(IC) |
---|
| 1758 | CALL LASTNB ( CA(IC), LEN(CA(IC)), LCA ) |
---|
| 1759 | IF( LCA .GT. LENA(IC) ) THEN |
---|
| 1760 | WRITE( IOU,* ) ' **PD2160 error--string too long for' |
---|
| 1761 | WRITE( IOU,* ) ' auxiliary variable A(I), I=', |
---|
| 1762 | * NAUXV-NAUXC+IC |
---|
| 1763 | WRITE( IOU,* ) |
---|
| 1764 | * ' At independent variable mark X2=', CX2(1:LENX(2)) |
---|
| 1765 | WRITE( IOU,* ) ' LENGTH, LENA(I)= ', LCA, LENA(IC) |
---|
| 1766 | WRITE( IOU,* ) ' A(I)=', CA(IC)(1:LCA) |
---|
| 1767 | NDIAG = NDIAG + 1 |
---|
| 1768 | ENDIF |
---|
| 1769 | IF( LGT( CA(IC)(1:LENA(IC)), CAMISS(IC)(1:LENA(IC)) )) THEN |
---|
| 1770 | WRITE( IOU,* ) |
---|
| 1771 | * ' **PD2160 error--auxiliary variable .GT. its missing value' |
---|
| 1772 | WRITE( IOU,* ) |
---|
| 1773 | * ' at independent variable mark X2= ',CX2(1:LENX(2)) |
---|
| 1774 | WRITE( IOU,* ) ' Auxiliary variable index=', |
---|
| 1775 | * NAUXV-NAUXC+IC |
---|
| 1776 | WRITE( IOU,* ) ' A(I)= ', CA(IC)(1:LENA(IC)) |
---|
| 1777 | WRITE( IOU,* ) ' AMISS(I)= ', CAMISS(IC)(1:LENA(IC)) |
---|
| 1778 | NDIAG = NDIAG + 1 |
---|
| 1779 | ENDIF |
---|
| 1780 | 20 CONTINUE |
---|
| 1781 | ENDIF |
---|
| 1782 | C |
---|
| 1783 | IF( NX .GT. 0 .AND. NX .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 1784 | DO 30 I=1,NX |
---|
| 1785 | CALL PARDAT ( DUM, NV+1, NFIND, 'PD2160', 6, 'V(I,N)', 6, |
---|
| 1786 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1787 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1788 | NVALS = NVALS + NFIND |
---|
| 1789 | IF( IERR .LT. 0 ) THEN |
---|
| 1790 | GOTO 103 |
---|
| 1791 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1792 | RETURN |
---|
| 1793 | ELSE |
---|
| 1794 | X1(I) = DUM(1) |
---|
| 1795 | DO 26 N=1,NV |
---|
| 1796 | V(I,N) = DUM(N+1) |
---|
| 1797 | IF( V(I,N) .GT. VMISS(N) ) THEN |
---|
| 1798 | WRITE( IOU,* ) |
---|
| 1799 | * ' **PD2160 error--primary variable .GT. its missing value' |
---|
| 1800 | WRITE( IOU,* ) |
---|
| 1801 | * ' at independent variable mark X2= ',CX2(1:LENX(2)) |
---|
| 1802 | WRITE( IOU,* ) ' I, N, V(I,N), VMISS(N)=', |
---|
| 1803 | * I, N, V(I,N), VMISS(N) |
---|
| 1804 | NDIAG = NDIAG + 1 |
---|
| 1805 | ENDIF |
---|
| 1806 | 26 CONTINUE |
---|
| 1807 | ENDIF |
---|
| 1808 | 30 CONTINUE |
---|
| 1809 | ENDIF |
---|
| 1810 | RETURN |
---|
| 1811 | C |
---|
| 1812 | C Flag EOF. |
---|
| 1813 | C |
---|
| 1814 | 100 CONTINUE |
---|
| 1815 | IERR = -1 |
---|
| 1816 | RETURN |
---|
| 1817 | 101 CONTINUE |
---|
| 1818 | IF( NFIND .GT. 0 .AND. NFIND .LT. NAUXV-NAUXC ) THEN |
---|
| 1819 | WRITE( IOU,* ) ' ***PD2160 error--premature EOF in line',LINE+1 |
---|
| 1820 | WRITE( IOU,* ) ' while reading real auxiliary variables' |
---|
| 1821 | WRITE( IOU,* ) ' Last successfully read value of X2= ', |
---|
| 1822 | * CX2(1:LENX(2)) |
---|
| 1823 | WRITE( IOU,* ) ' Number of values expected in record=', |
---|
| 1824 | * NAUXV-NAUXC |
---|
| 1825 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1826 | NDIAG = NDIAG + 1 |
---|
| 1827 | ENDIF |
---|
| 1828 | RETURN |
---|
| 1829 | 102 CONTINUE |
---|
| 1830 | IERR = -1 |
---|
| 1831 | WRITE( IOU,* ) ' ***PD2160 error--EOF while reading character' |
---|
| 1832 | WRITE( IOU,* ) ' auxiliary variable number ', NAUXV-NAUXC+IC |
---|
| 1833 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 1834 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 1835 | WRITE( IOU,* ) ' NAUXV, NAUXC=', NAUXV, NAUXC |
---|
| 1836 | NDIAG = NDIAG + 1 |
---|
| 1837 | RETURN |
---|
| 1838 | 103 CONTINUE |
---|
| 1839 | WRITE( IOU,* ) |
---|
| 1840 | * ' ***PD2160 error--EOF while reading X1(I),V(I,N), I= ', I |
---|
| 1841 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 1842 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 1843 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 1844 | WRITE( IOU,* ) ' Number of values expected in record=', NV |
---|
| 1845 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1846 | NDIAG = NDIAG + 1 |
---|
| 1847 | RETURN |
---|
| 1848 | C |
---|
| 1849 | C Flag read error. |
---|
| 1850 | C |
---|
| 1851 | 200 CONTINUE |
---|
| 1852 | IERR = 1 |
---|
| 1853 | WRITE( IOU,* ) |
---|
| 1854 | * ' ***PD2160 error reading independent variable X2' |
---|
| 1855 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 1856 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 1857 | NDIAG = NDIAG + 1 |
---|
| 1858 | RETURN |
---|
| 1859 | 202 CONTINUE |
---|
| 1860 | IERR = 1 |
---|
| 1861 | WRITE( IOU,* ) ' ***PD2160 error reading character' |
---|
| 1862 | WRITE( IOU,* ) ' auxiliary variable number ', NAUXV-NAUXC+IC |
---|
| 1863 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 1864 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 1865 | WRITE( IOU,* ) ' NAUXV, NAUXC=', NAUXV, NAUXC |
---|
| 1866 | NDIAG = NDIAG + 1 |
---|
| 1867 | RETURN |
---|
| 1868 | END |
---|
| 1869 | SUBROUTINE PD2310 ( X2, A, AMISS, NAUXV, V, VMISS, X1, MAXX1, |
---|
| 1870 | * NX, NV, DX, |
---|
| 1871 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 1872 | * IUN, IOU, NDIAG, IERR ) |
---|
| 1873 | C |
---|
| 1874 | C Subroutine to read a data record group for FFI=2310. |
---|
| 1875 | C This routine reads the expected number of values, checks for extra |
---|
| 1876 | C values within the record, tests dependent variables against their |
---|
| 1877 | C missing values, and counts the number of lines, number of characters, |
---|
| 1878 | C and the number of blanks in the data records. |
---|
| 1879 | C |
---|
| 1880 | C IERR = 0 = successful read. |
---|
| 1881 | C = -1 = EOF encountered. |
---|
| 1882 | C = +1 = read error. |
---|
| 1883 | C = +2 = error in value of NX. |
---|
| 1884 | C |
---|
| 1885 | C Required routines: CKMISV, CKMSXV, PARDAT. |
---|
| 1886 | C |
---|
| 1887 | CHARACTER*(*) CDUM |
---|
| 1888 | CHARACTER*(*) CRFMT |
---|
| 1889 | C |
---|
| 1890 | DIMENSION A( * ), AMISS( * ), DUM( * ) |
---|
| 1891 | DIMENSION V( MAXX1,* ), VMISS( * ), X1( * ), DX( * ) |
---|
| 1892 | C |
---|
| 1893 | IERR = 0 |
---|
| 1894 | C |
---|
| 1895 | C Read a group of data records. |
---|
| 1896 | C |
---|
| 1897 | CALL PARDAT ( DUM, NAUXV+1, NFIND, 'PD2310', 6, 'X2,A(I)', 7, |
---|
| 1898 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1899 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1900 | NVALS = NVALS + NFIND |
---|
| 1901 | IF( IERR .LT. 0 ) THEN |
---|
| 1902 | GOTO 100 |
---|
| 1903 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1904 | RETURN |
---|
| 1905 | ELSE |
---|
| 1906 | X2 = DUM(1) |
---|
| 1907 | DO 20 I=1,NAUXV |
---|
| 1908 | A(I) = DUM(I+1) |
---|
| 1909 | 20 CONTINUE |
---|
| 1910 | NX = INT( A(1)+0.5 ) |
---|
| 1911 | DX(1) = A(3) |
---|
| 1912 | IF( NX .GT. MAXX1 .AND. NX .NE. INT(AMISS(1)+0.5) ) THEN |
---|
| 1913 | WRITE( IOU,* ) ' ***PD2310 error--NX(1) too large' |
---|
| 1914 | WRITE( IOU,* ) ' MAXX1,NX(1)=', MAXX1, NX |
---|
| 1915 | IERR = 2 |
---|
| 1916 | NDIAG = NDIAG + 1 |
---|
| 1917 | RETURN |
---|
| 1918 | ENDIF |
---|
| 1919 | CALL CKMISV ( A, AMISS, NAUXV, X2, |
---|
| 1920 | * 'A(I)', 4, 'X2', 2, 'PD2310', 6, NDIAG, IOU ) |
---|
| 1921 | ENDIF |
---|
| 1922 | C |
---|
| 1923 | IF( NX .GT. 0 .AND. NX .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 1924 | DO 30 N=1,NV |
---|
| 1925 | CALL PARDAT ( DUM, NX, NFIND, 'PD2310', 6, 'V(I,N)', 6, |
---|
| 1926 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 1927 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 1928 | NVALS = NVALS + NFIND |
---|
| 1929 | IF( IERR .LT. 0 ) THEN |
---|
| 1930 | GOTO 102 |
---|
| 1931 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 1932 | RETURN |
---|
| 1933 | ELSE |
---|
| 1934 | DO 26 I=1,NX |
---|
| 1935 | V(I,N) = DUM(I) |
---|
| 1936 | 26 CONTINUE |
---|
| 1937 | ENDIF |
---|
| 1938 | 30 CONTINUE |
---|
| 1939 | CALL CKMSXV ( V, MAXX1, VMISS, NV, X2, NX, |
---|
| 1940 | * 'V(N)', 4, 'X2', 2, 'PD2310', 6, NDIAG, IOU ) |
---|
| 1941 | C |
---|
| 1942 | C Define X1(I). |
---|
| 1943 | C |
---|
| 1944 | DO 40 I=1,NX |
---|
| 1945 | X1(I) = A(2) + A(3) * FLOAT( I-1 ) |
---|
| 1946 | 40 CONTINUE |
---|
| 1947 | ENDIF |
---|
| 1948 | RETURN |
---|
| 1949 | C |
---|
| 1950 | C Flag EOF. |
---|
| 1951 | C |
---|
| 1952 | 100 CONTINUE |
---|
| 1953 | IF( NFIND .GT. 0 .AND. NFIND .LT. NAUXV+1 ) THEN |
---|
| 1954 | WRITE( IOU,* ) ' ***PD2310 error--premature EOF in line',LINE+1 |
---|
| 1955 | WRITE( IOU,* ) ' while reading X2,A(I)' |
---|
| 1956 | WRITE( IOU,* ) ' Last successfully read value of X2=', X2 |
---|
| 1957 | WRITE( IOU,* ) ' Number of values expected in record=', |
---|
| 1958 | * NAUXV+1 |
---|
| 1959 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1960 | NDIAG = NDIAG + 1 |
---|
| 1961 | ENDIF |
---|
| 1962 | RETURN |
---|
| 1963 | 102 CONTINUE |
---|
| 1964 | WRITE( IOU,* ) ' ***PD2310 encountered EOF while reading values' |
---|
| 1965 | WRITE( IOU,* ) ' of primary variable V(I,N), N=', N |
---|
| 1966 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 1967 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 1968 | WRITE( IOU,* ) ' Number of values expected in record=', NX |
---|
| 1969 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 1970 | NDIAG = NDIAG + 1 |
---|
| 1971 | RETURN |
---|
| 1972 | END |
---|
| 1973 | SUBROUTINE PD3010 ( X3, A, AMISS, NAUXV, V, VMISS, MAXX1, NX, NV, |
---|
| 1974 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 1975 | * IUN, IOU, ISU, RETDAT, NDIAG, IERR ) |
---|
| 1976 | C |
---|
| 1977 | C Subroutine to read a data record group for FFI=3010. |
---|
| 1978 | C This routine reads the expected number of values, checks for extra |
---|
| 1979 | C values within the record, tests dependent variables against their |
---|
| 1980 | C missing values, and counts the number of lines, number of characters, |
---|
| 1981 | C and the number of blanks in the data records. |
---|
| 1982 | C |
---|
| 1983 | C IERR = 0 = successful read. |
---|
| 1984 | C = -1 = EOF encountered. |
---|
| 1985 | C = +1 = read error. |
---|
| 1986 | C If RETDAT=.TRUE. then the primary variable values are written to |
---|
| 1987 | C the scratch file unit ISU. |
---|
| 1988 | C |
---|
| 1989 | C Required routines: CKMISV, CKMSXV, PARDAT. |
---|
| 1990 | C |
---|
| 1991 | C |
---|
| 1992 | LOGICAL RETDAT |
---|
| 1993 | C |
---|
| 1994 | CHARACTER*(*) CDUM |
---|
| 1995 | CHARACTER*(*) CRFMT |
---|
| 1996 | C |
---|
| 1997 | DIMENSION A( * ), AMISS( * ), DUM( * ) |
---|
| 1998 | DIMENSION V( MAXX1,* ), VMISS( * ), NX( * ) |
---|
| 1999 | C |
---|
| 2000 | IERR = 0 |
---|
| 2001 | C |
---|
| 2002 | C Read a group of data records. |
---|
| 2003 | C |
---|
| 2004 | CALL PARDAT ( DUM, NAUXV+1, NFIND, 'PD3010', 6, 'X3,A(I)', 7, |
---|
| 2005 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 2006 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 2007 | NVALS = NVALS + NFIND |
---|
| 2008 | IF( IERR .LT. 0 ) THEN |
---|
| 2009 | GOTO 100 |
---|
| 2010 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 2011 | RETURN |
---|
| 2012 | ELSE |
---|
| 2013 | X3 = DUM(1) |
---|
| 2014 | IF( NAUXV .GT. 0 ) THEN |
---|
| 2015 | DO 20 IA=1,NAUXV |
---|
| 2016 | A(IA) = DUM(IA+1) |
---|
| 2017 | 20 CONTINUE |
---|
| 2018 | CALL CKMISV ( A, AMISS, NAUXV, X3, |
---|
| 2019 | * 'A(I)', 4, 'X3', 2, 'PD3010', 6, NDIAG, IOU ) |
---|
| 2020 | ENDIF |
---|
| 2021 | ENDIF |
---|
| 2022 | C |
---|
| 2023 | DO 30 N=1,NV |
---|
| 2024 | DO 28 J=1,NX(2) |
---|
| 2025 | CALL PARDAT ( DUM, NX, NFIND, 'PD3010', 6, 'V(I,J,N)', 8, |
---|
| 2026 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 2027 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 2028 | NVALS = NVALS + NFIND |
---|
| 2029 | IF( IERR .LT. 0 ) THEN |
---|
| 2030 | GOTO 102 |
---|
| 2031 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 2032 | RETURN |
---|
| 2033 | ELSE |
---|
| 2034 | DO 26 I=1,NX(1) |
---|
| 2035 | V(I,1) = DUM(I) |
---|
| 2036 | 26 CONTINUE |
---|
| 2037 | ENDIF |
---|
| 2038 | CALL CKMSXV ( V, MAXX1, VMISS(N), 1, X3, NX, |
---|
| 2039 | * 'V(N)', 4, 'X3', 2, 'PD3010', 6, NDIAG, IOU ) |
---|
| 2040 | IF( RETDAT ) THEN |
---|
| 2041 | WRITE( ISU ) ( V(I,1), I=1,NX(1) ) |
---|
| 2042 | ENDIF |
---|
| 2043 | 28 CONTINUE |
---|
| 2044 | 30 CONTINUE |
---|
| 2045 | RETURN |
---|
| 2046 | C |
---|
| 2047 | C Flag EOF. |
---|
| 2048 | C |
---|
| 2049 | 100 CONTINUE |
---|
| 2050 | IF( NFIND .GT. 0 .AND. NFIND .LT. NAUXV+1 ) THEN |
---|
| 2051 | WRITE( IOU,* ) ' ***PD3010 error--premature EOF in line',LINE+1 |
---|
| 2052 | WRITE( IOU,* ) ' while reading X3,A(I)' |
---|
| 2053 | WRITE( IOU,* ) ' Last successfully read value of X3=', X3 |
---|
| 2054 | WRITE( IOU,* ) ' Number of values expected in record=', |
---|
| 2055 | * NAUXV+1 |
---|
| 2056 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 2057 | NDIAG = NDIAG + 1 |
---|
| 2058 | ENDIF |
---|
| 2059 | RETURN |
---|
| 2060 | 102 CONTINUE |
---|
| 2061 | WRITE( IOU,* ) ' ***PD3010 encountered EOF while reading values' |
---|
| 2062 | WRITE( IOU,* ) ' of primary variable V(I,J,N), J,N=', J, N |
---|
| 2063 | WRITE( IOU,* ) ' at independent variable mark X3=', X3 |
---|
| 2064 | WRITE( IOU,* ) ' NX(1), NX(2), NV=', NX(1), NX(2), NV |
---|
| 2065 | WRITE( IOU,* ) ' Number of values expected in record=', NX(1) |
---|
| 2066 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 2067 | NDIAG = NDIAG + 1 |
---|
| 2068 | RETURN |
---|
| 2069 | END |
---|
| 2070 | SUBROUTINE PD4010 ( X4, A, AMISS, NAUXV, V, VMISS, MAXX1, NX, NV, |
---|
| 2071 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 2072 | * IUN, IOU, ISU, RETDAT, NDIAG, IERR ) |
---|
| 2073 | C |
---|
| 2074 | C Subroutine to read a data record group for FFI=4010. |
---|
| 2075 | C This routine reads the expected number of values, checks for extra |
---|
| 2076 | C values within the record, tests dependent variables against their |
---|
| 2077 | C missing values, and counts the number of lines, number of characters, |
---|
| 2078 | C and the number of blanks in the data records. |
---|
| 2079 | C |
---|
| 2080 | C IERR = 0 = successful read. |
---|
| 2081 | C = -1 = EOF encountered. |
---|
| 2082 | C = +1 = read error. |
---|
| 2083 | C If RETDAT=.TRUE. then the primary variable values are written to |
---|
| 2084 | C the scratch file unit ISU. |
---|
| 2085 | C |
---|
| 2086 | C Required routines: CKMISV, CKMSXV, PARDAT. |
---|
| 2087 | C |
---|
| 2088 | C |
---|
| 2089 | LOGICAL RETDAT |
---|
| 2090 | C |
---|
| 2091 | CHARACTER*(*) CDUM |
---|
| 2092 | CHARACTER*(*) CRFMT |
---|
| 2093 | C |
---|
| 2094 | DIMENSION A( * ), AMISS( * ), DUM( * ) |
---|
| 2095 | DIMENSION V( MAXX1,* ), VMISS( * ), NX( * ) |
---|
| 2096 | C |
---|
| 2097 | IERR = 0 |
---|
| 2098 | C |
---|
| 2099 | C Read a group of data records. |
---|
| 2100 | C |
---|
| 2101 | CALL PARDAT ( DUM, NAUXV+1, NFIND, 'PD4010', 6, 'X4,A(I)', 7, |
---|
| 2102 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 2103 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 2104 | NVALS = NVALS + NFIND |
---|
| 2105 | IF( IERR .LT. 0 ) THEN |
---|
| 2106 | GOTO 100 |
---|
| 2107 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 2108 | RETURN |
---|
| 2109 | ELSE |
---|
| 2110 | X4 = DUM(1) |
---|
| 2111 | IF( NAUXV .GT. 0 ) THEN |
---|
| 2112 | DO 20 IA=1,NAUXV |
---|
| 2113 | A(IA) = DUM(IA+1) |
---|
| 2114 | 20 CONTINUE |
---|
| 2115 | CALL CKMISV ( A, AMISS, NAUXV, X4, |
---|
| 2116 | * 'A(I)', 4, 'X4', 2, 'PD4010', 6, NDIAG, IOU ) |
---|
| 2117 | ENDIF |
---|
| 2118 | ENDIF |
---|
| 2119 | C |
---|
| 2120 | DO 30 N=1,NV |
---|
| 2121 | DO 28 K=1,NX(3) |
---|
| 2122 | DO 26 J=1,NX(2) |
---|
| 2123 | CALL PARDAT ( DUM, NX, NFIND, 'PD4010', 6, |
---|
| 2124 | * 'V(I,J,K,N)', 10, |
---|
| 2125 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 2126 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 2127 | NVALS = NVALS + NFIND |
---|
| 2128 | IF( IERR .LT. 0 ) THEN |
---|
| 2129 | GOTO 102 |
---|
| 2130 | ELSE IF( IERR .GT. 0 ) THEN |
---|
| 2131 | RETURN |
---|
| 2132 | ELSE |
---|
| 2133 | DO 24 I=1,NX(1) |
---|
| 2134 | V(I,1) = DUM(I) |
---|
| 2135 | 24 CONTINUE |
---|
| 2136 | ENDIF |
---|
| 2137 | CALL CKMSXV ( V, MAXX1, VMISS(N), 1, X4, NX, |
---|
| 2138 | * 'V(N)', 4, 'X4', 2, 'PD4010', 6, NDIAG, IOU) |
---|
| 2139 | IF( RETDAT ) THEN |
---|
| 2140 | WRITE( ISU ) ( V(I,1), I=1,NX(1) ) |
---|
| 2141 | ENDIF |
---|
| 2142 | 26 CONTINUE |
---|
| 2143 | 28 CONTINUE |
---|
| 2144 | 30 CONTINUE |
---|
| 2145 | RETURN |
---|
| 2146 | C |
---|
| 2147 | C Flag EOF. |
---|
| 2148 | C |
---|
| 2149 | 100 CONTINUE |
---|
| 2150 | IF( NFIND .GT. 0 .AND. NFIND .LT. NAUXV+1 ) THEN |
---|
| 2151 | WRITE( IOU,* ) ' ***PD4010 error--premature EOF in line',LINE+1 |
---|
| 2152 | WRITE( IOU,* ) ' while reading X4,A(I)' |
---|
| 2153 | WRITE( IOU,* ) ' Last successfully read value of X4=', X4 |
---|
| 2154 | WRITE( IOU,* ) ' Number of values expected in record=', |
---|
| 2155 | * NAUXV+1 |
---|
| 2156 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 2157 | NDIAG = NDIAG + 1 |
---|
| 2158 | ENDIF |
---|
| 2159 | RETURN |
---|
| 2160 | 102 CONTINUE |
---|
| 2161 | WRITE( IOU,* ) ' ***PD4010 encountered EOF while reading values' |
---|
| 2162 | WRITE( IOU,* ) ' of primary variable V(I,J,K,N), J,K,N=', J,K,N |
---|
| 2163 | WRITE( IOU,* ) ' at independent variable mark X4=', X4 |
---|
| 2164 | WRITE( IOU,* ) ' NX(1), NX(2), NX(3), NV=',(NX(M),M=1,3), NV |
---|
| 2165 | WRITE( IOU,* ) ' Number of values expected in record=', NX(1) |
---|
| 2166 | WRITE( IOU,* ) ' Number of values found in record=', NFIND |
---|
| 2167 | NDIAG = NDIAG + 1 |
---|
| 2168 | RETURN |
---|
| 2169 | END |
---|
| 2170 | SUBROUTINE PRDATA ( X1, X2, X3, X4, CX2, LENX, DX, NX, |
---|
| 2171 | * A, AMISS, CA, LENA, NAUXV, NAUXC, |
---|
| 2172 | * V, MAXX1, NV, NVPM, CWFMT, IOU, ISU, |
---|
| 2173 | * ISUBV ) |
---|
| 2174 | C |
---|
| 2175 | C Subroutine to print data records. |
---|
| 2176 | C ISUBV is defined in subroutine RHEAD and used in this routine. |
---|
| 2177 | C |
---|
| 2178 | C Required routines: CHFMT. |
---|
| 2179 | C |
---|
| 2180 | C History: |
---|
| 2181 | C 91-10-23 (SEG) - Omit printing records with X1 if NX(1)=AMISS(1) |
---|
| 2182 | C or NX(1)=0, for formats 2110, 2160, 2310. |
---|
| 2183 | C |
---|
| 2184 | C |
---|
| 2185 | CHARACTER*(*) CA( * ) |
---|
| 2186 | CHARACTER*(*) CWFMT |
---|
| 2187 | CHARACTER*(*) CX2 |
---|
| 2188 | C |
---|
| 2189 | DIMENSION A( * ), AMISS( * ), LENA( * ), V( MAXX1,* ) |
---|
| 2190 | DIMENSION LENX( * ), X1( * ), X2( * ), X3( * ) |
---|
| 2191 | DIMENSION DX( * ), NX( * ) |
---|
| 2192 | C |
---|
| 2193 | GO TO ( 1001, 1010, 1020, |
---|
| 2194 | * 2010, 2110, 2160, 2310, |
---|
| 2195 | * 3010, 4010 ) ISUBV |
---|
| 2196 | WRITE( IOU,* ) ' ***PRDATA error--improper value for ISUBV=', |
---|
| 2197 | * ISUBV |
---|
| 2198 | RETURN |
---|
| 2199 | 1001 CONTINUE |
---|
| 2200 | WRITE(IOU,*) X1(1), ( V(N,1), N=1,NV ) |
---|
| 2201 | RETURN |
---|
| 2202 | 1010 CONTINUE |
---|
| 2203 | WRITE(IOU,*) X1(1), ( A(IA), IA=1,NAUXV ) |
---|
| 2204 | WRITE(IOU,*) ( V(N,1), N=1,NV ) |
---|
| 2205 | RETURN |
---|
| 2206 | 1020 CONTINUE |
---|
| 2207 | WRITE(IOU,*) ( X1(I), I=1,NVPM ) |
---|
| 2208 | WRITE(IOU,*) ( A(IA), IA=1,NAUXV ) |
---|
| 2209 | DO 30 N=1,NV |
---|
| 2210 | WRITE(IOU,*) ( V(I,N), I=1,NVPM ) |
---|
| 2211 | 30 CONTINUE |
---|
| 2212 | RETURN |
---|
| 2213 | 2010 CONTINUE |
---|
| 2214 | WRITE(IOU,*) X2(1), ( A(IA), IA=1,NAUXV ) |
---|
| 2215 | DO 40 N=1,NV |
---|
| 2216 | WRITE(IOU,*) ( V(I,N), I=1,NX(1) ) |
---|
| 2217 | 40 CONTINUE |
---|
| 2218 | RETURN |
---|
| 2219 | 2110 CONTINUE |
---|
| 2220 | WRITE(IOU,*) X2(1), ( A(IA), IA=1,NAUXV ) |
---|
| 2221 | WRITE(IOU,*) 'NX(1)=', NX(1) |
---|
| 2222 | IF( NX(1) .GT. 0 .AND. NX(1) .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 2223 | DO 50 I=1,NX(1) |
---|
| 2224 | WRITE(IOU,*) X1(I), ( V(I,N), N=1,NV ) |
---|
| 2225 | 50 CONTINUE |
---|
| 2226 | ENDIF |
---|
| 2227 | RETURN |
---|
| 2228 | 2160 CONTINUE |
---|
| 2229 | CALL CHFMT ( LENX(2), CWFMT ) |
---|
| 2230 | WRITE(IOU,FMT=CWFMT) CX2(1:LENX(2)) |
---|
| 2231 | WRITE(IOU,*) ( A(IA), IA=1,NAUXV-NAUXC ) |
---|
| 2232 | WRITE(IOU,*) 'NX(1)=', NX(1) |
---|
| 2233 | DO 60 IA=1,NAUXC |
---|
| 2234 | CALL CHFMT ( LENA(IA), CWFMT ) |
---|
| 2235 | WRITE(IOU,FMT=CWFMT) CA(IA)(1:LENA(IA)) |
---|
| 2236 | 60 CONTINUE |
---|
| 2237 | IF( NX(1) .GT. 0 .AND. NX(1) .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 2238 | DO 62 I=1,NX(1) |
---|
| 2239 | WRITE(IOU,*) X1(I), ( V(I,N), N=1,NV ) |
---|
| 2240 | 62 CONTINUE |
---|
| 2241 | ENDIF |
---|
| 2242 | RETURN |
---|
| 2243 | 2310 CONTINUE |
---|
| 2244 | WRITE(IOU,*) X2(1), ( A(IA), IA=1,NAUXV ) |
---|
| 2245 | WRITE(IOU,*) 'NX(1),X1(1),DX(1)=', NX(1), X1(1), DX(1) |
---|
| 2246 | IF( NX(1) .GT. 0 .AND. NX(1) .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 2247 | DO 70 N=1,NV |
---|
| 2248 | WRITE(IOU,*) ( V(I,N), I=1,NX(1) ) |
---|
| 2249 | 70 CONTINUE |
---|
| 2250 | ENDIF |
---|
| 2251 | RETURN |
---|
| 2252 | 3010 CONTINUE |
---|
| 2253 | WRITE(IOU,*) X3(1), ( A(IA), IA=1,NAUXV ) |
---|
| 2254 | DO 80 N=1,NV |
---|
| 2255 | DO 78 J=1,NX(2) |
---|
| 2256 | READ(ISU) ( V(I,1), I=1,NX(1) ) |
---|
| 2257 | WRITE(IOU,*) ( V(I,1), I=1,NX(1) ) |
---|
| 2258 | 78 CONTINUE |
---|
| 2259 | 80 CONTINUE |
---|
| 2260 | RETURN |
---|
| 2261 | 4010 CONTINUE |
---|
| 2262 | WRITE(IOU,*) X4, ( A(IA), IA=1,NAUXV ) |
---|
| 2263 | DO 90 N=1,NV |
---|
| 2264 | DO 88 K=1,NX(3) |
---|
| 2265 | DO 86 J=1,NX(2) |
---|
| 2266 | READ(ISU) ( V(I,1), I=1,NX(1) ) |
---|
| 2267 | WRITE(IOU,*) ( V(I,1), I=1,NX(1) ) |
---|
| 2268 | 86 CONTINUE |
---|
| 2269 | 88 CONTINUE |
---|
| 2270 | 90 CONTINUE |
---|
| 2271 | RETURN |
---|
| 2272 | END |
---|
| 2273 | SUBROUTINE PRHEAD ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 2274 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 2275 | * DX, NX, NXDEF, LENX, XNAME, X1, X2, X3, |
---|
| 2276 | * NV, NVPM, VSCAL, VMISS, VNAME, |
---|
| 2277 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 2278 | * NAUXC, LENA, CAMISS, |
---|
| 2279 | * NSCOML, SCOM, NNCOML, NCOM, CWFMT, IOU ) |
---|
| 2280 | C |
---|
| 2281 | C Subroutine to print file header info. |
---|
| 2282 | C |
---|
| 2283 | C Required routines: CHFMT, LASTNB. |
---|
| 2284 | C |
---|
| 2285 | CHARACTER*(*) ANAME( * ) |
---|
| 2286 | CHARACTER*(*) CAMISS( * ) |
---|
| 2287 | CHARACTER*(*) CWFMT |
---|
| 2288 | CHARACTER*(*) MNAME |
---|
| 2289 | CHARACTER*(*) NCOM( * ) |
---|
| 2290 | CHARACTER*(*) ONAME |
---|
| 2291 | CHARACTER*(*) ORG |
---|
| 2292 | CHARACTER*(*) SCOM( * ) |
---|
| 2293 | CHARACTER*(*) SNAME |
---|
| 2294 | CHARACTER*(*) VNAME( * ) |
---|
| 2295 | CHARACTER*(*) XNAME( * ) |
---|
| 2296 | C |
---|
| 2297 | DIMENSION DX( * ), NX( * ), NXDEF( * ) |
---|
| 2298 | DIMENSION X1( * ), X2( * ), X3( * ) |
---|
| 2299 | DIMENSION AMISS( * ), ASCAL( * ), LENA( * ) |
---|
| 2300 | DIMENSION VMISS( * ), VSCAL( * ), LENX( * ) |
---|
| 2301 | C |
---|
| 2302 | C |
---|
| 2303 | C Obtain NIV. |
---|
| 2304 | C |
---|
| 2305 | NIV = IFFI / 1000 |
---|
| 2306 | C |
---|
| 2307 | WRITE(IOU,*) NLHEAD, IFFI |
---|
| 2308 | CALL LASTNB ( ONAME, LEN(ONAME), LL ) |
---|
| 2309 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2310 | WRITE(IOU,FMT=CWFMT) ONAME(1:LL) |
---|
| 2311 | CALL LASTNB ( ORG, LEN(ORG), LL ) |
---|
| 2312 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2313 | WRITE(IOU,FMT=CWFMT) ORG(1:LL) |
---|
| 2314 | CALL LASTNB ( SNAME, LEN(SNAME), LL ) |
---|
| 2315 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2316 | WRITE(IOU,FMT=CWFMT) SNAME(1:LL) |
---|
| 2317 | CALL LASTNB ( MNAME, LEN(MNAME), LL ) |
---|
| 2318 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2319 | WRITE(IOU,FMT=CWFMT) MNAME(1:LL) |
---|
| 2320 | WRITE(IOU,*) IVOL, NVOL |
---|
| 2321 | WRITE(IOU,*) IYR, IMO, IDY |
---|
| 2322 | WRITE(IOU,*) IRYR, IRMO, IRDY |
---|
| 2323 | IF( IFFI .EQ. 2160 ) THEN |
---|
| 2324 | WRITE(IOU,*) DX(1) |
---|
| 2325 | WRITE(IOU,*) LENX(2) |
---|
| 2326 | ELSE IF( IFFI .EQ. 2310 ) THEN |
---|
| 2327 | WRITE(IOU,*) DX(2) |
---|
| 2328 | ELSE |
---|
| 2329 | WRITE(IOU,*) ( DX(I), I=1,NIV ) |
---|
| 2330 | ENDIF |
---|
| 2331 | IF( IFFI .EQ. 1020 ) THEN |
---|
| 2332 | WRITE(IOU,*) NVPM |
---|
| 2333 | ELSE IF( IFFI .EQ. 2010 .OR. |
---|
| 2334 | * IFFI .EQ. 3010 .OR. IFFI .EQ. 4010 ) THEN |
---|
| 2335 | WRITE(IOU,*) ( NX(I), I=1,NIV-1 ) |
---|
| 2336 | WRITE(IOU,*) ( NXDEF(I), I=1,NIV-1 ) |
---|
| 2337 | WRITE(IOU,*) ( X1(I), I=1,NX(1) ) |
---|
| 2338 | IF( IFFI .EQ. 3010 ) THEN |
---|
| 2339 | WRITE(IOU,*) ( X2(J), J=1,NX(2) ) |
---|
| 2340 | ELSE IF( IFFI .EQ. 4010 ) THEN |
---|
| 2341 | WRITE(IOU,*) ( X2(J), J=1,NX(2) ) |
---|
| 2342 | WRITE(IOU,*) ( X3(K), K=1,NX(3) ) |
---|
| 2343 | ENDIF |
---|
| 2344 | ENDIF |
---|
| 2345 | DO 20 IS=1,NIV |
---|
| 2346 | CALL LASTNB ( XNAME(IS), LEN(XNAME(IS)), LL ) |
---|
| 2347 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2348 | WRITE(IOU,FMT=CWFMT) XNAME(IS)(1:LL) |
---|
| 2349 | 20 CONTINUE |
---|
| 2350 | WRITE(IOU,*) NV |
---|
| 2351 | WRITE(IOU,*) ( VSCAL(N), N=1,NV ) |
---|
| 2352 | WRITE(IOU,*) ( VMISS(N), N=1,NV ) |
---|
| 2353 | DO 30 N=1,NV |
---|
| 2354 | CALL LASTNB ( VNAME(N), LEN(VNAME(N)), LL ) |
---|
| 2355 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2356 | WRITE(IOU,FMT=CWFMT) VNAME(N)(1:LL) |
---|
| 2357 | 30 CONTINUE |
---|
| 2358 | IF( IFFI .EQ. 2160 ) THEN |
---|
| 2359 | WRITE(IOU,*) NAUXV |
---|
| 2360 | WRITE(IOU,*) NAUXC |
---|
| 2361 | WRITE(IOU,*) ( ASCAL(IA), IA=1,NAUXV-NAUXC ) |
---|
| 2362 | WRITE(IOU,*) ( AMISS(IA), IA=1,NAUXV-NAUXC ) |
---|
| 2363 | WRITE(IOU,*) ( LENA(IA), IA=1,NAUXC ) |
---|
| 2364 | DO 40 IA=1,NAUXC |
---|
| 2365 | CALL LASTNB ( CAMISS(IA), LEN(CAMISS(IA)), LL ) |
---|
| 2366 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2367 | WRITE(IOU,FMT=CWFMT) CAMISS(IA)(1:LL) |
---|
| 2368 | 40 CONTINUE |
---|
| 2369 | ELSE IF( IFFI .NE. 1001 ) THEN |
---|
| 2370 | WRITE(IOU,*) NAUXV |
---|
| 2371 | WRITE(IOU,*) ( ASCAL(IA), IA=1,NAUXV ) |
---|
| 2372 | WRITE(IOU,*) ( AMISS(IA), IA=1,NAUXV ) |
---|
| 2373 | ENDIF |
---|
| 2374 | IF( IFFI .NE. 1001 ) THEN |
---|
| 2375 | DO 50 IA=1,NAUXV |
---|
| 2376 | CALL LASTNB ( ANAME(IA), LEN(ANAME(IA)), LL ) |
---|
| 2377 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2378 | WRITE(IOU,FMT=CWFMT) ANAME(IA)(1:LL) |
---|
| 2379 | 50 CONTINUE |
---|
| 2380 | ENDIF |
---|
| 2381 | WRITE(IOU,*) NSCOML |
---|
| 2382 | DO 60 K=1,NSCOML |
---|
| 2383 | CALL LASTNB ( SCOM(K), LEN(SCOM(K)), LL ) |
---|
| 2384 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2385 | WRITE(IOU,FMT=CWFMT) SCOM(K)(1:LL) |
---|
| 2386 | 60 CONTINUE |
---|
| 2387 | WRITE(IOU,*) NNCOML |
---|
| 2388 | DO 70 K=1,NNCOML |
---|
| 2389 | CALL LASTNB ( NCOM(K), LEN(NCOM(K)), LL ) |
---|
| 2390 | CALL CHFMT ( LL, CWFMT ) |
---|
| 2391 | WRITE(IOU,FMT=CWFMT) NCOM(K)(1:LL) |
---|
| 2392 | 70 CONTINUE |
---|
| 2393 | RETURN |
---|
| 2394 | END |
---|
| 2395 | SUBROUTINE RD1001 ( X1, V, NV, IUN, IOU, NDIAG, IERR ) |
---|
| 2396 | C |
---|
| 2397 | C Subroutine to read a data record for FFI=1001. |
---|
| 2398 | C IERR = 0 = successful read. |
---|
| 2399 | C = -1 = EOF encountered. |
---|
| 2400 | C = +1 = read error. |
---|
| 2401 | C |
---|
| 2402 | C |
---|
| 2403 | DIMENSION V( * ) |
---|
| 2404 | C |
---|
| 2405 | IERR = 0 |
---|
| 2406 | READ( IUN,*,ERR=200,END=100 ) X1, ( V(N), N=1,NV ) |
---|
| 2407 | RETURN |
---|
| 2408 | 100 CONTINUE |
---|
| 2409 | IERR = -1 |
---|
| 2410 | RETURN |
---|
| 2411 | 200 CONTINUE |
---|
| 2412 | IERR = 1 |
---|
| 2413 | WRITE( IOU,* ) ' ***RD1001 read error' |
---|
| 2414 | WRITE( IOU,* ) ' Last successfully read value of X1=', X1 |
---|
| 2415 | NDIAG = NDIAG + 1 |
---|
| 2416 | RETURN |
---|
| 2417 | END |
---|
| 2418 | SUBROUTINE RD1010 ( X1, A, NAUXV, V, NV, |
---|
| 2419 | * IUN, IOU, NDIAG, IERR ) |
---|
| 2420 | C |
---|
| 2421 | C Subroutine to read a data record group for FFI=1010. |
---|
| 2422 | C IERR = 0 = successful read. |
---|
| 2423 | C = -1 = EOF encountered. |
---|
| 2424 | C = +1 = read error. |
---|
| 2425 | C |
---|
| 2426 | C |
---|
| 2427 | DIMENSION A( * ), V( * ) |
---|
| 2428 | C |
---|
| 2429 | IERR = 0 |
---|
| 2430 | C |
---|
| 2431 | C Read a group of data records. |
---|
| 2432 | C |
---|
| 2433 | IF( NAUXV .GT. 0 ) THEN |
---|
| 2434 | READ( IUN,*,ERR=200,END=100 ) X1, ( A(IA), IA=1,NAUXV ) |
---|
| 2435 | ELSE |
---|
| 2436 | READ( IUN,*,ERR=201,END=100 ) X1 |
---|
| 2437 | ENDIF |
---|
| 2438 | READ( IUN,*,ERR=202,END=102 ) ( V(N), N=1,NV ) |
---|
| 2439 | RETURN |
---|
| 2440 | C |
---|
| 2441 | C Flag EOF. |
---|
| 2442 | C |
---|
| 2443 | 100 CONTINUE |
---|
| 2444 | IERR = -1 |
---|
| 2445 | RETURN |
---|
| 2446 | 102 CONTINUE |
---|
| 2447 | IERR = -1 |
---|
| 2448 | WRITE( IOU,* ) |
---|
| 2449 | * ' ***RD1010 encountered EOF while reading primary variables.' |
---|
| 2450 | WRITE( IOU,* ) ' Incomplete primary variable list at X1=', X1 |
---|
| 2451 | WRITE( IOU,* ) ' NV=', NV |
---|
| 2452 | NDIAG = NDIAG + 1 |
---|
| 2453 | RETURN |
---|
| 2454 | C |
---|
| 2455 | C Flag read error. |
---|
| 2456 | C |
---|
| 2457 | 200 CONTINUE |
---|
| 2458 | IERR = 1 |
---|
| 2459 | WRITE( IOU,* ) |
---|
| 2460 | * ' ***RD1010 error reading independent and auxilary variables' |
---|
| 2461 | WRITE( IOU,* ) ' Last successfully read value of X1=', X1 |
---|
| 2462 | WRITE( IOU,* ) ' NAUXV=', NAUXV |
---|
| 2463 | NDIAG = NDIAG + 1 |
---|
| 2464 | RETURN |
---|
| 2465 | 201 CONTINUE |
---|
| 2466 | IERR = 1 |
---|
| 2467 | WRITE( IOU,* ) |
---|
| 2468 | * ' ***RD1010 error reading independent variable X1' |
---|
| 2469 | WRITE( IOU,* ) ' Last successfully read value of X1=', X1 |
---|
| 2470 | NDIAG = NDIAG + 1 |
---|
| 2471 | RETURN |
---|
| 2472 | 202 CONTINUE |
---|
| 2473 | IERR = 1 |
---|
| 2474 | WRITE( IOU,* ) |
---|
| 2475 | * ' ***RD1010 error reading primary variables at X1=',X1 |
---|
| 2476 | WRITE( IOU,* ) ' NV=', NV |
---|
| 2477 | NDIAG = NDIAG + 1 |
---|
| 2478 | RETURN |
---|
| 2479 | END |
---|
| 2480 | SUBROUTINE RD1020 ( X1, DX, A, NAUXV, V, MAXX1, NVPM, NV, |
---|
| 2481 | * IUN, IOU, NDIAG, IERR ) |
---|
| 2482 | C |
---|
| 2483 | C Subroutine to read a data record group for FFI=1020. |
---|
| 2484 | C IERR = 0 = successful read. |
---|
| 2485 | C = -1 = EOF encountered. |
---|
| 2486 | C = +1 = read error. |
---|
| 2487 | C |
---|
| 2488 | C |
---|
| 2489 | DIMENSION A( * ), V( MAXX1,* ), X1( * ) |
---|
| 2490 | C |
---|
| 2491 | IERR = 0 |
---|
| 2492 | C |
---|
| 2493 | C Read a group of data records. |
---|
| 2494 | C |
---|
| 2495 | IF( NAUXV .GT. 0 ) THEN |
---|
| 2496 | READ( IUN,*,ERR=201,END=100 ) X1(1), ( A(IA), IA=1,NAUXV ) |
---|
| 2497 | ELSE |
---|
| 2498 | READ( IUN,*,ERR=200,END=100 ) X1(1) |
---|
| 2499 | ENDIF |
---|
| 2500 | DO 30 N=1,NV |
---|
| 2501 | READ( IUN,*,ERR=202,END=102 ) ( V(I,N), I=1,NVPM ) |
---|
| 2502 | 30 CONTINUE |
---|
| 2503 | C |
---|
| 2504 | C Define X1 values. |
---|
| 2505 | C |
---|
| 2506 | DO 40 I=2,NVPM |
---|
| 2507 | X1(I) = X1(1) + DX * FLOAT( I-1 ) |
---|
| 2508 | 40 CONTINUE |
---|
| 2509 | RETURN |
---|
| 2510 | C |
---|
| 2511 | C Flag EOF. |
---|
| 2512 | C |
---|
| 2513 | 100 CONTINUE |
---|
| 2514 | IERR = -1 |
---|
| 2515 | RETURN |
---|
| 2516 | 102 CONTINUE |
---|
| 2517 | IERR = -1 |
---|
| 2518 | WRITE( IOU,* ) ' ***RD1020 encountered EOF while reading values' |
---|
| 2519 | WRITE( IOU,* ) ' of primary variable V(I,N), N=', N |
---|
| 2520 | WRITE( IOU,* ) ' at independent variable mark X1(1)=', X1(1) |
---|
| 2521 | WRITE( IOU,* ) ' NV, NVPM=', NV, NVPM |
---|
| 2522 | NDIAG = NDIAG + 1 |
---|
| 2523 | RETURN |
---|
| 2524 | C |
---|
| 2525 | C Flag read error. |
---|
| 2526 | C |
---|
| 2527 | 200 CONTINUE |
---|
| 2528 | IERR = 1 |
---|
| 2529 | WRITE( IOU,* ) |
---|
| 2530 | * ' ***RD1020 error reading independent variable X1(1)' |
---|
| 2531 | WRITE( IOU,* ) ' Last successfully read value of X1(1)=', X1(1) |
---|
| 2532 | NDIAG = NDIAG + 1 |
---|
| 2533 | RETURN |
---|
| 2534 | 201 CONTINUE |
---|
| 2535 | IERR = 1 |
---|
| 2536 | WRITE( IOU,* ) |
---|
| 2537 | * ' ***RD1020 error reading independent and auxilary variables' |
---|
| 2538 | WRITE( IOU,* ) ' Last successfully read value of X1(1)=', X1(1) |
---|
| 2539 | WRITE( IOU,* ) ' NAUXV=', NAUXV |
---|
| 2540 | NDIAG = NDIAG + 1 |
---|
| 2541 | RETURN |
---|
| 2542 | 202 CONTINUE |
---|
| 2543 | IERR = 1 |
---|
| 2544 | WRITE( IOU,* ) ' ***RD1020 error reading values' |
---|
| 2545 | WRITE( IOU,* ) ' of primary variable V(I,N), N=', N |
---|
| 2546 | WRITE( IOU,* ) ' at independent variable mark X1(1)=', X1(1) |
---|
| 2547 | WRITE( IOU,* ) ' NV, NVPM=', NV, NVPM |
---|
| 2548 | NDIAG = NDIAG + 1 |
---|
| 2549 | RETURN |
---|
| 2550 | END |
---|
| 2551 | SUBROUTINE RD2010 ( X2, A, NAUXV, V, MAXX1, NX, NV, |
---|
| 2552 | * IUN, IOU, NDIAG, IERR ) |
---|
| 2553 | C |
---|
| 2554 | C Subroutine to read a data record group for FFI=2010. |
---|
| 2555 | C IERR = 0 = successful read. |
---|
| 2556 | C = -1 = EOF encountered. |
---|
| 2557 | C = +1 = read error. |
---|
| 2558 | C |
---|
| 2559 | C |
---|
| 2560 | DIMENSION A( * ), V( MAXX1,1 ) |
---|
| 2561 | C |
---|
| 2562 | IERR = 0 |
---|
| 2563 | C |
---|
| 2564 | C Read a group of data records. |
---|
| 2565 | C |
---|
| 2566 | IF( NAUXV .GT. 0 ) THEN |
---|
| 2567 | READ( IUN,*,ERR=201,END=100 ) X2, ( A(IA), IA=1,NAUXV ) |
---|
| 2568 | ELSE |
---|
| 2569 | READ( IUN,*,ERR=200,END=100 ) X2 |
---|
| 2570 | ENDIF |
---|
| 2571 | DO 30 N=1,NV |
---|
| 2572 | READ( IUN,*,ERR=202,END=102 ) ( V(I,N), I=1,NX ) |
---|
| 2573 | 30 CONTINUE |
---|
| 2574 | RETURN |
---|
| 2575 | C |
---|
| 2576 | C Flag EOF. |
---|
| 2577 | C |
---|
| 2578 | 100 CONTINUE |
---|
| 2579 | IERR = -1 |
---|
| 2580 | RETURN |
---|
| 2581 | 102 CONTINUE |
---|
| 2582 | IERR = -1 |
---|
| 2583 | WRITE( IOU,* ) ' ***RD2010 encountered EOF while reading values' |
---|
| 2584 | WRITE( IOU,* ) ' of primary variable V(I,N), N=', N |
---|
| 2585 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 2586 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 2587 | NDIAG = NDIAG + 1 |
---|
| 2588 | RETURN |
---|
| 2589 | C |
---|
| 2590 | C Flag read error. |
---|
| 2591 | C |
---|
| 2592 | 200 CONTINUE |
---|
| 2593 | IERR = 1 |
---|
| 2594 | WRITE( IOU,* ) |
---|
| 2595 | * ' ***RD2010 error reading independent variable X2' |
---|
| 2596 | WRITE( IOU,* ) ' Last successfully read value of X2=', X2 |
---|
| 2597 | NDIAG = NDIAG + 1 |
---|
| 2598 | RETURN |
---|
| 2599 | 201 CONTINUE |
---|
| 2600 | IERR = 1 |
---|
| 2601 | WRITE( IOU,* ) |
---|
| 2602 | * ' ***RD2010 error reading independent and auxilary variables' |
---|
| 2603 | WRITE( IOU,* ) ' Last successfully read value of X2=', X2 |
---|
| 2604 | WRITE( IOU,* ) ' NAUXV=', NAUXV |
---|
| 2605 | NDIAG = NDIAG + 1 |
---|
| 2606 | RETURN |
---|
| 2607 | 202 CONTINUE |
---|
| 2608 | IERR = 1 |
---|
| 2609 | WRITE( IOU,* ) ' ***RD2010 error reading values' |
---|
| 2610 | WRITE( IOU,* ) ' of primary variable V(I,N), N=', N |
---|
| 2611 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 2612 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 2613 | NDIAG = NDIAG + 1 |
---|
| 2614 | RETURN |
---|
| 2615 | END |
---|
| 2616 | SUBROUTINE RD2110 ( X1, X2, A, AMISS, NAUXV, V, MAXX1, NX, NV, |
---|
| 2617 | * IUN, IOU, NDIAG, IERR ) |
---|
| 2618 | C |
---|
| 2619 | C Subroutine to read a data record group for FFI=2110. |
---|
| 2620 | C IERR = 0 = successful read. |
---|
| 2621 | C = -1 = EOF encountered. |
---|
| 2622 | C = +1 = read error. |
---|
| 2623 | C = +2 = error in value of NX |
---|
| 2624 | C |
---|
| 2625 | C |
---|
| 2626 | DIMENSION A( * ), AMISS( * ), V( MAXX1,* ), X1( * ) |
---|
| 2627 | C |
---|
| 2628 | IERR = 0 |
---|
| 2629 | C |
---|
| 2630 | C Read a group of data records. |
---|
| 2631 | C |
---|
| 2632 | IF( NAUXV .GT. 1 ) THEN |
---|
| 2633 | READ( IUN,*,ERR=200,END=100 ) X2, NX, ( A(IA), IA=2,NAUXV ) |
---|
| 2634 | ELSE |
---|
| 2635 | READ( IUN,*,ERR=200,END=100 ) X2, NX |
---|
| 2636 | ENDIF |
---|
| 2637 | A(1) = FLOAT( NX ) |
---|
| 2638 | IF( NX .GT. MAXX1 .AND. NX .NE. INT(AMISS(1)+0.5)) THEN |
---|
| 2639 | WRITE( IOU,* ) ' ***RD2110 error--NX(1) too large' |
---|
| 2640 | WRITE( IOU,* ) ' MAXX1,NX(1)=', MAXX1, NX |
---|
| 2641 | IERR = 2 |
---|
| 2642 | NDIAG = NDIAG + 1 |
---|
| 2643 | RETURN |
---|
| 2644 | ENDIF |
---|
| 2645 | C |
---|
| 2646 | IF( NX .GT. 0 .AND. NX .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 2647 | DO 30 I=1,NX |
---|
| 2648 | READ( IUN,*,ERR=202,END=102 ) X1(I), ( V(I,N), N=1,NV ) |
---|
| 2649 | 30 CONTINUE |
---|
| 2650 | ENDIF |
---|
| 2651 | RETURN |
---|
| 2652 | C |
---|
| 2653 | C Flag EOF. |
---|
| 2654 | C |
---|
| 2655 | 100 CONTINUE |
---|
| 2656 | IERR = -1 |
---|
| 2657 | RETURN |
---|
| 2658 | 102 CONTINUE |
---|
| 2659 | IERR = -1 |
---|
| 2660 | WRITE( IOU,* ) ' ***RD2110 encountered EOF' |
---|
| 2661 | WRITE( IOU,* ) ' while reading record containing X1(I), I= ', I |
---|
| 2662 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 2663 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 2664 | NDIAG = NDIAG + 1 |
---|
| 2665 | RETURN |
---|
| 2666 | C |
---|
| 2667 | C Flag read error. |
---|
| 2668 | C |
---|
| 2669 | 200 CONTINUE |
---|
| 2670 | IERR = 1 |
---|
| 2671 | WRITE( IOU,* ) |
---|
| 2672 | * ' ***RD2110 error reading independent and auxilary variables' |
---|
| 2673 | WRITE( IOU,* ) ' Last successfully read value of X2=', X2 |
---|
| 2674 | WRITE( IOU,* ) ' NAUXV=', NAUXV |
---|
| 2675 | NDIAG = NDIAG + 1 |
---|
| 2676 | RETURN |
---|
| 2677 | 202 CONTINUE |
---|
| 2678 | IERR = 1 |
---|
| 2679 | WRITE( IOU,* ) |
---|
| 2680 | * ' ***RD2010 error while reading record containing X1(I), I= ',I |
---|
| 2681 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 2682 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 2683 | NDIAG = NDIAG + 1 |
---|
| 2684 | RETURN |
---|
| 2685 | END |
---|
| 2686 | SUBROUTINE RD2160 ( X1, CX2, LENX, |
---|
| 2687 | * A, AMISS, CA, NAUXV, NAUXC, |
---|
| 2688 | * V, MAXX1, NX, NV, |
---|
| 2689 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 2690 | C |
---|
| 2691 | C Subroutine to read a data record group for FFI=2160. |
---|
| 2692 | C IERR = 0 = successful read. |
---|
| 2693 | C = -1 = EOF encountered. |
---|
| 2694 | C = +1 = read error. |
---|
| 2695 | C = +2 = error in value of NX. |
---|
| 2696 | C |
---|
| 2697 | C |
---|
| 2698 | CHARACTER*(*) CA( * ) |
---|
| 2699 | CHARACTER*(*) CRFMT |
---|
| 2700 | CHARACTER*(*) CX2 |
---|
| 2701 | C |
---|
| 2702 | DIMENSION A( * ), AMISS( * ), V( MAXX1,* ) |
---|
| 2703 | DIMENSION LENX( * ), X1( * ) |
---|
| 2704 | C |
---|
| 2705 | IERR = 0 |
---|
| 2706 | C |
---|
| 2707 | C Read a group of data records. |
---|
| 2708 | C |
---|
| 2709 | READ( IUN,FMT=CRFMT,ERR=200,END=100 ) CX2 |
---|
| 2710 | IF( NAUXV-NAUXC .GT. 1 ) THEN |
---|
| 2711 | READ( IUN,*,ERR=201,END=101 ) NX, ( A(IA), IA=2,NAUXV-NAUXC ) |
---|
| 2712 | ELSE |
---|
| 2713 | READ( IUN,*,ERR=201,END=101 ) NX |
---|
| 2714 | ENDIF |
---|
| 2715 | A(1) = FLOAT( NX ) |
---|
| 2716 | IF( NX .GT. MAXX1 .AND. NX .NE. INT(AMISS(1)+0.5) ) THEN |
---|
| 2717 | WRITE( IOU,* ) ' ***RD2160 error--NX(1) too large' |
---|
| 2718 | WRITE( IOU,* ) ' MAXX1,NX(1)=', MAXX1, NX |
---|
| 2719 | IERR = 2 |
---|
| 2720 | NDIAG = NDIAG + 1 |
---|
| 2721 | RETURN |
---|
| 2722 | ENDIF |
---|
| 2723 | IF( NAUXC .GT. 0 ) THEN |
---|
| 2724 | DO 20 IC=1,NAUXC |
---|
| 2725 | READ( IUN,FMT=CRFMT,ERR=202,END=102 ) CA(IC) |
---|
| 2726 | 20 CONTINUE |
---|
| 2727 | ENDIF |
---|
| 2728 | IF( NX .GT. 0 .AND. NX .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 2729 | DO 30 I=1,NX |
---|
| 2730 | READ( IUN,*,ERR=203,END=103 ) X1(I), ( V(I,N), N=1,NV ) |
---|
| 2731 | 30 CONTINUE |
---|
| 2732 | ENDIF |
---|
| 2733 | RETURN |
---|
| 2734 | C |
---|
| 2735 | C Flag EOF. |
---|
| 2736 | C |
---|
| 2737 | 100 CONTINUE |
---|
| 2738 | IERR = -1 |
---|
| 2739 | RETURN |
---|
| 2740 | 101 CONTINUE |
---|
| 2741 | IERR = -1 |
---|
| 2742 | WRITE( IOU,* ) |
---|
| 2743 | * ' ***RD2160 EOF while reading real auxiliary variables.' |
---|
| 2744 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 2745 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 2746 | WRITE( IOU,* ) ' NAUXV-NAUXC=', NAUXV-NAUXC |
---|
| 2747 | NDIAG = NDIAG + 1 |
---|
| 2748 | RETURN |
---|
| 2749 | 102 CONTINUE |
---|
| 2750 | IERR = -1 |
---|
| 2751 | WRITE( IOU,* ) ' ***RD2160 EOF while reading character' |
---|
| 2752 | WRITE( IOU,* ) ' auxiliary variable number ', NAUXV-NAUXC+IC |
---|
| 2753 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 2754 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 2755 | WRITE( IOU,* ) ' NAUXV, NAUXC=', NAUXV, NAUXC |
---|
| 2756 | NDIAG = NDIAG + 1 |
---|
| 2757 | RETURN |
---|
| 2758 | 103 CONTINUE |
---|
| 2759 | IERR = -1 |
---|
| 2760 | WRITE( IOU,* ) |
---|
| 2761 | * ' ***RD2160 EOF while reading record containing X1(I), I= ', I |
---|
| 2762 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 2763 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 2764 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 2765 | NDIAG = NDIAG + 1 |
---|
| 2766 | RETURN |
---|
| 2767 | C |
---|
| 2768 | C Flag read error. |
---|
| 2769 | C |
---|
| 2770 | 200 CONTINUE |
---|
| 2771 | IERR = 1 |
---|
| 2772 | WRITE( IOU,* ) |
---|
| 2773 | * ' ***RD2160 error reading independent variable X2' |
---|
| 2774 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 2775 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 2776 | NDIAG = NDIAG + 1 |
---|
| 2777 | RETURN |
---|
| 2778 | 201 CONTINUE |
---|
| 2779 | IERR = 1 |
---|
| 2780 | WRITE( IOU,* ) |
---|
| 2781 | * ' ***RD2160 error reading real auxilary variables' |
---|
| 2782 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 2783 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 2784 | WRITE( IOU,* ) ' NAUXV-NAUXC=', NAUXV-NAUXC |
---|
| 2785 | NDIAG = NDIAG + 1 |
---|
| 2786 | RETURN |
---|
| 2787 | 202 CONTINUE |
---|
| 2788 | IERR = 1 |
---|
| 2789 | WRITE( IOU,* ) ' ***RD2160 error reading character' |
---|
| 2790 | WRITE( IOU,* ) ' auxiliary variable number ', NAUXV-NAUXC+IC |
---|
| 2791 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 2792 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 2793 | WRITE( IOU,* ) ' NAUXV, NAUXC=', NAUXV, NAUXC |
---|
| 2794 | NDIAG = NDIAG + 1 |
---|
| 2795 | RETURN |
---|
| 2796 | 203 CONTINUE |
---|
| 2797 | IERR = 1 |
---|
| 2798 | WRITE( IOU,* ) |
---|
| 2799 | * ' ***RD2160 error while reading record containing X1(I), I= ', I |
---|
| 2800 | WRITE( IOU,* ) ' Last successfully read value of X2 is:' |
---|
| 2801 | WRITE( IOU,* ) ' ',CX2(1:LENX(2)) |
---|
| 2802 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 2803 | NDIAG = NDIAG + 1 |
---|
| 2804 | RETURN |
---|
| 2805 | END |
---|
| 2806 | SUBROUTINE RD2310 ( X2, A, AMISS, NAUXV, V, X1, MAXX1, NX, NV, DX, |
---|
| 2807 | * IUN, IOU, NDIAG, IERR ) |
---|
| 2808 | C |
---|
| 2809 | C Subroutine to read a data record group for FFI=2310. |
---|
| 2810 | C IERR = 0 = successful read. |
---|
| 2811 | C = -1 = EOF encountered. |
---|
| 2812 | C = +1 = read error. |
---|
| 2813 | C = +2 = error in value of NX. |
---|
| 2814 | C |
---|
| 2815 | C History: |
---|
| 2816 | C 91-10-23 (SEG) - Omit defining X1(I) if NX=AMISS(1) or NX=0. |
---|
| 2817 | C |
---|
| 2818 | C |
---|
| 2819 | DIMENSION A( * ), AMISS( * ), V( MAXX1,* ), X1( * ), DX( * ) |
---|
| 2820 | C |
---|
| 2821 | IERR = 0 |
---|
| 2822 | C |
---|
| 2823 | C Read a group of data records. |
---|
| 2824 | C |
---|
| 2825 | READ( IUN,*,ERR=200,END=100 ) X2, NX, ( A(IA), IA=2,NAUXV ) |
---|
| 2826 | A(1) = FLOAT( NX ) |
---|
| 2827 | DX(1) = A(3) |
---|
| 2828 | IF( NX .GT. MAXX1 .AND. NX .NE. INT(AMISS(1)+0.5) ) THEN |
---|
| 2829 | WRITE( IOU,* ) ' ***RD2310 error--NX(1) too large' |
---|
| 2830 | WRITE( IOU,* ) ' MAXX1,NX(1)=', MAXX1, NX |
---|
| 2831 | IERR = 2 |
---|
| 2832 | NDIAG = NDIAG + 1 |
---|
| 2833 | RETURN |
---|
| 2834 | ENDIF |
---|
| 2835 | IF( NX .GT. 0 .AND. NX .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 2836 | DO 30 N=1,NV |
---|
| 2837 | READ( IUN,*,ERR=202,END=102 ) ( V(I,N), I=1,NX ) |
---|
| 2838 | 30 CONTINUE |
---|
| 2839 | C |
---|
| 2840 | C Define X1(I). |
---|
| 2841 | C |
---|
| 2842 | DO 40 I=1,NX |
---|
| 2843 | X1(I) = A(2) + A(3) * FLOAT( I-1 ) |
---|
| 2844 | 40 CONTINUE |
---|
| 2845 | ENDIF |
---|
| 2846 | RETURN |
---|
| 2847 | C |
---|
| 2848 | C Flag EOF. |
---|
| 2849 | C |
---|
| 2850 | 100 CONTINUE |
---|
| 2851 | IERR = -1 |
---|
| 2852 | RETURN |
---|
| 2853 | 102 CONTINUE |
---|
| 2854 | IERR = -1 |
---|
| 2855 | WRITE( IOU,* ) ' ***RD2310 encountered EOF while reading values' |
---|
| 2856 | WRITE( IOU,* ) ' of primary variable V(I,N), N=', N |
---|
| 2857 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 2858 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 2859 | NDIAG = NDIAG + 1 |
---|
| 2860 | RETURN |
---|
| 2861 | C |
---|
| 2862 | C Flag read error. |
---|
| 2863 | C |
---|
| 2864 | 200 CONTINUE |
---|
| 2865 | IERR = 1 |
---|
| 2866 | WRITE( IOU,* ) ' ***RD2310 error reading independent variable X2' |
---|
| 2867 | WRITE( IOU,* ) ' Last successfully read value of X2=', X2 |
---|
| 2868 | WRITE( IOU,* ) ' NAUXV=', NAUXV |
---|
| 2869 | NDIAG = NDIAG + 1 |
---|
| 2870 | RETURN |
---|
| 2871 | 202 CONTINUE |
---|
| 2872 | IERR = 1 |
---|
| 2873 | WRITE( IOU,* ) ' ***RD2310 error while reading values' |
---|
| 2874 | WRITE( IOU,* ) ' of primary variable V(I,N), N=', N |
---|
| 2875 | WRITE( IOU,* ) ' at independent variable mark X2=', X2 |
---|
| 2876 | WRITE( IOU,* ) ' NV, NX(1)=', NV, NX |
---|
| 2877 | NDIAG = NDIAG + 1 |
---|
| 2878 | RETURN |
---|
| 2879 | END |
---|
| 2880 | SUBROUTINE RD3010 ( X3, A, NAUXV, V, MAXX1, NX, NV, |
---|
| 2881 | * IUN, IOU, ISU, RETDAT, NDIAG, IERR ) |
---|
| 2882 | C |
---|
| 2883 | C Subroutine to read a data record group for FFI=3010. |
---|
| 2884 | C IERR = 0 = successful read. |
---|
| 2885 | C = -1 = EOF encountered. |
---|
| 2886 | C = +1 = read error. |
---|
| 2887 | C If RETDAT=.TRUE. then the primary variable values are written to |
---|
| 2888 | C the scratch file unit ISU. |
---|
| 2889 | C |
---|
| 2890 | LOGICAL RETDAT |
---|
| 2891 | C |
---|
| 2892 | DIMENSION A( * ), V( MAXX1,* ), NX( * ) |
---|
| 2893 | C |
---|
| 2894 | IERR = 0 |
---|
| 2895 | C |
---|
| 2896 | C Read a group of data records. |
---|
| 2897 | C |
---|
| 2898 | IF( NAUXV .GT. 0 ) THEN |
---|
| 2899 | READ( IUN,*,ERR=201,END=100 ) X3, ( A(IA), IA=1,NAUXV ) |
---|
| 2900 | ELSE |
---|
| 2901 | READ( IUN,*,ERR=200,END=100 ) X3 |
---|
| 2902 | ENDIF |
---|
| 2903 | DO 30 N=1,NV |
---|
| 2904 | DO 28 J=1,NX(2) |
---|
| 2905 | READ( IUN,*,ERR=202,END=102 ) ( V(I,1), I=1,NX(1) ) |
---|
| 2906 | IF( RETDAT ) THEN |
---|
| 2907 | WRITE( ISU ) ( V(I,1), I=1,NX(1) ) |
---|
| 2908 | ENDIF |
---|
| 2909 | 28 CONTINUE |
---|
| 2910 | 30 CONTINUE |
---|
| 2911 | RETURN |
---|
| 2912 | C |
---|
| 2913 | C Flag EOF. |
---|
| 2914 | C |
---|
| 2915 | 100 CONTINUE |
---|
| 2916 | IERR = -1 |
---|
| 2917 | RETURN |
---|
| 2918 | 102 CONTINUE |
---|
| 2919 | IERR = -1 |
---|
| 2920 | WRITE( IOU,* ) ' ***RD3010 encountered EOF while reading values' |
---|
| 2921 | WRITE( IOU,* ) ' of primary variable V(I,J,N), J,N=', J, N |
---|
| 2922 | WRITE( IOU,* ) ' at independent variable mark X3=', X3 |
---|
| 2923 | WRITE( IOU,* ) ' NX(1), NX(2), NV=', NX(1), NX(2), NV |
---|
| 2924 | NDIAG = NDIAG + 1 |
---|
| 2925 | RETURN |
---|
| 2926 | C |
---|
| 2927 | C Flag read error. |
---|
| 2928 | C |
---|
| 2929 | 200 CONTINUE |
---|
| 2930 | IERR = 1 |
---|
| 2931 | WRITE( IOU,* ) |
---|
| 2932 | * ' ***RD3010 error reading independent variable X3' |
---|
| 2933 | WRITE( IOU,* ) ' Last successfully read value of X3=', X3 |
---|
| 2934 | NDIAG = NDIAG + 1 |
---|
| 2935 | RETURN |
---|
| 2936 | 201 CONTINUE |
---|
| 2937 | IERR = 1 |
---|
| 2938 | WRITE( IOU,* ) |
---|
| 2939 | * ' ***RD3010 error reading independent and auxilary variables' |
---|
| 2940 | WRITE( IOU,* ) ' Last successfully read value of X3=', X3 |
---|
| 2941 | WRITE( IOU,* ) ' NAUXV=', NAUXV |
---|
| 2942 | NDIAG = NDIAG + 1 |
---|
| 2943 | RETURN |
---|
| 2944 | 202 CONTINUE |
---|
| 2945 | IERR = 1 |
---|
| 2946 | WRITE( IOU,* ) ' ***RD3010 error while reading values' |
---|
| 2947 | WRITE( IOU,* ) ' of primary variable V(I,J,N), J,N=', J, N |
---|
| 2948 | WRITE( IOU,* ) ' at independent variable mark X3=', X3 |
---|
| 2949 | WRITE( IOU,* ) ' NX(1), NX(2), NV=', NX(1), NX(2), NV |
---|
| 2950 | NDIAG = NDIAG + 1 |
---|
| 2951 | RETURN |
---|
| 2952 | END |
---|
| 2953 | SUBROUTINE RD4010 ( X4, A, NAUXV, V, MAXX1, |
---|
| 2954 | * NX, NV, IUN, IOU, ISU, RETDAT, NDIAG, IERR ) |
---|
| 2955 | C |
---|
| 2956 | C Subroutine to read a data record group for FFI=4010. |
---|
| 2957 | C IERR = 0 = successful read. |
---|
| 2958 | C = -1 = EOF encountered. |
---|
| 2959 | C = +1 = read error. |
---|
| 2960 | C If RETDAT=.TRUE. then the primary variable values are written to |
---|
| 2961 | C the scratch file unit ISU. |
---|
| 2962 | C |
---|
| 2963 | LOGICAL RETDAT |
---|
| 2964 | C |
---|
| 2965 | DIMENSION A( * ), V( MAXX1,* ), NX( * ) |
---|
| 2966 | C |
---|
| 2967 | IERR = 0 |
---|
| 2968 | C |
---|
| 2969 | C Read a group of data records. |
---|
| 2970 | C |
---|
| 2971 | IF( NAUXV .GT. 0 ) THEN |
---|
| 2972 | READ( IUN,*,ERR=201,END=100 ) X4, ( A(IA), IA=1,NAUXV ) |
---|
| 2973 | ELSE |
---|
| 2974 | READ( IUN,*,ERR=200,END=100 ) X4 |
---|
| 2975 | ENDIF |
---|
| 2976 | DO 30 N=1,NV |
---|
| 2977 | DO 28 K=1,NX(3) |
---|
| 2978 | DO 26 J=1,NX(2) |
---|
| 2979 | READ( IUN,*,ERR=202,END=102 ) ( V(I,1), I=1,NX(1) ) |
---|
| 2980 | IF( RETDAT ) THEN |
---|
| 2981 | WRITE( ISU ) ( V(I,1), I=1,NX(1) ) |
---|
| 2982 | ENDIF |
---|
| 2983 | 26 CONTINUE |
---|
| 2984 | 28 CONTINUE |
---|
| 2985 | 30 CONTINUE |
---|
| 2986 | RETURN |
---|
| 2987 | C |
---|
| 2988 | C Flag EOF. |
---|
| 2989 | C |
---|
| 2990 | 100 CONTINUE |
---|
| 2991 | IERR = -1 |
---|
| 2992 | RETURN |
---|
| 2993 | 102 CONTINUE |
---|
| 2994 | IERR = -1 |
---|
| 2995 | WRITE( IOU,* ) ' ***RD4010 encountered EOF while reading values' |
---|
| 2996 | WRITE( IOU,* ) ' of primary variable V(I,J,K,N), J,K,N=', J,K,N |
---|
| 2997 | WRITE( IOU,* ) ' at independent variable mark X4=', X4 |
---|
| 2998 | WRITE( IOU,* ) ' NX(1), NX(2), NX(3), NV=',(NX(M),M=1,3), NV |
---|
| 2999 | NDIAG = NDIAG + 1 |
---|
| 3000 | RETURN |
---|
| 3001 | C |
---|
| 3002 | C Flag read error. |
---|
| 3003 | C |
---|
| 3004 | 200 CONTINUE |
---|
| 3005 | IERR = 1 |
---|
| 3006 | WRITE( IOU,* ) |
---|
| 3007 | * ' ***RD4010 error reading independent variable X4' |
---|
| 3008 | WRITE( IOU,* ) ' Last successfully read value of X4=', X4 |
---|
| 3009 | NDIAG = NDIAG + 1 |
---|
| 3010 | RETURN |
---|
| 3011 | 201 CONTINUE |
---|
| 3012 | IERR = 1 |
---|
| 3013 | WRITE( IOU,* ) |
---|
| 3014 | * ' ***RD4010 error reading independent and auxilary variables' |
---|
| 3015 | WRITE( IOU,* ) ' Last successfully read value of X4=', X4 |
---|
| 3016 | WRITE( IOU,* ) ' NAUXV=', NAUXV |
---|
| 3017 | NDIAG = NDIAG + 1 |
---|
| 3018 | RETURN |
---|
| 3019 | 202 CONTINUE |
---|
| 3020 | IERR = 1 |
---|
| 3021 | WRITE( IOU,* ) ' ***RD4010 error reading values' |
---|
| 3022 | WRITE( IOU,* ) ' of primary variable V(I,J,K,N), J,K,N=', J,K,N |
---|
| 3023 | WRITE( IOU,* ) ' at independent variable mark X4=', X4 |
---|
| 3024 | WRITE( IOU,* ) ' NX(1), NX(2), NX(3), NV=',(NX(M),M=1,3), NV |
---|
| 3025 | NDIAG = NDIAG + 1 |
---|
| 3026 | RETURN |
---|
| 3027 | END |
---|
| 3028 | SUBROUTINE RDATA ( X1, X2, X3, X4, CX2, LENX, DX, NX, |
---|
| 3029 | * A, AMISS, CA, CAMISS, LENA, NAUXV, NAUXC, |
---|
| 3030 | * V, VMISS, MAXX1, NV, NVPM, |
---|
| 3031 | * CDUM, DUM, LINE, NBIDR, NCIDR, NVALS, |
---|
| 3032 | * CRFMT, RETDAT, PARSIT, |
---|
| 3033 | * IUN, IOU, ISU, NIVM, |
---|
| 3034 | * ISUBV, NDIAG, IERR ) |
---|
| 3035 | C |
---|
| 3036 | C Subroutine to drive data reading routines and check independent |
---|
| 3037 | C variable values. |
---|
| 3038 | C ISUBV is defined in subroutine RHEAD and used in this routine |
---|
| 3039 | C to determine which routine to call. |
---|
| 3040 | C |
---|
| 3041 | C Required routines: L3RVAL, |
---|
| 3042 | C PD1001, PD1010, PD1020, |
---|
| 3043 | C PD2010, PD2110, PD2160, PD2310, |
---|
| 3044 | C PD3010, PD4010, |
---|
| 3045 | C RD1001, RD1010, RD1020, |
---|
| 3046 | C RD2010, RD2110, RD2160, RD2310, |
---|
| 3047 | C RD3010, RD4010, |
---|
| 3048 | C TCIVM, TSTDX, TMON3, TMONO, TRIVM. |
---|
| 3049 | C |
---|
| 3050 | C History: |
---|
| 3051 | C 91-10-23 (SEG) Added PARSIT code. |
---|
| 3052 | C Omit testing of X1 if NX(1)=AMISS(1) or NX(1)=0 for |
---|
| 3053 | C formats 2110, 2160. |
---|
| 3054 | C 91-06-26 (SEG) Improved DX(1) tests for FFI 1020. |
---|
| 3055 | C |
---|
| 3056 | PARAMETER ( MXVAL = 3 ) |
---|
| 3057 | C |
---|
| 3058 | LOGICAL PARSIT, RETDAT |
---|
| 3059 | C |
---|
| 3060 | CHARACTER*(*) CA( * ) |
---|
| 3061 | CHARACTER*(*) CAMISS( * ) |
---|
| 3062 | CHARACTER*(*) CDUM |
---|
| 3063 | CHARACTER*(*) CRFMT |
---|
| 3064 | CHARACTER*255 CVAL( MXVAL ) |
---|
| 3065 | CHARACTER*(*) CX2 |
---|
| 3066 | CHARACTER*5 SUBFLG |
---|
| 3067 | C |
---|
| 3068 | DIMENSION A( * ), AMISS( * ), V( MAXX1,* ), VMISS( * ) |
---|
| 3069 | DIMENSION LENA( * ), LENX( * ), X1( * ), X2( * ), X3( * ) |
---|
| 3070 | DIMENSION DX( * ), NX( * ) |
---|
| 3071 | DIMENSION RVAL( MXVAL ), TVAL( 2 ) |
---|
| 3072 | DIMENSION DUM( * ) |
---|
| 3073 | C |
---|
| 3074 | DATA NSF / 5 / |
---|
| 3075 | DATA SUBFLG / 'RDATA' / |
---|
| 3076 | C |
---|
| 3077 | GO TO ( 1001, 1010, 1020, |
---|
| 3078 | * 2010, 2110, 2160, 2310, |
---|
| 3079 | * 3010, 4010 ) ISUBV |
---|
| 3080 | WRITE( IOU,* ) ' ***RDATA error--improper value for ISUBV=', |
---|
| 3081 | * ISUBV |
---|
| 3082 | NDIAG = NDIAG + 1 |
---|
| 3083 | IERR = 2 |
---|
| 3084 | RETURN |
---|
| 3085 | 1001 CONTINUE |
---|
| 3086 | IF( PARSIT ) THEN |
---|
| 3087 | CALL PD1001 ( X1, V, VMISS, NV, CDUM, DUM, |
---|
| 3088 | * LINE, NCIDR, NBIDR, NVALS, |
---|
| 3089 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3090 | ELSE |
---|
| 3091 | CALL RD1001 ( X1, V, NV, IUN, IOU, NDIAG, IERR ) |
---|
| 3092 | ENDIF |
---|
| 3093 | CALL TRIVM ( X1, DX, RVAL, 'X1', 2, NIVM, XIV0, |
---|
| 3094 | * NDIAG, IOU, IERR ) |
---|
| 3095 | RETURN |
---|
| 3096 | 1010 CONTINUE |
---|
| 3097 | IF( PARSIT ) THEN |
---|
| 3098 | CALL PD1010 ( X1, A, AMISS, NAUXV, V, VMISS, NV, |
---|
| 3099 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 3100 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3101 | ELSE |
---|
| 3102 | CALL RD1010 ( X1, A, NAUXV, V(1,1), NV, |
---|
| 3103 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3104 | ENDIF |
---|
| 3105 | CALL TRIVM ( X1, DX, RVAL, 'X1', 2, NIVM, XIV0, |
---|
| 3106 | * NDIAG, IOU, IERR ) |
---|
| 3107 | RETURN |
---|
| 3108 | 1020 CONTINUE |
---|
| 3109 | IF( PARSIT ) THEN |
---|
| 3110 | CALL PD1020 ( X1, DX, A, AMISS, NAUXV, |
---|
| 3111 | * V, VMISS, MAXX1, NVPM, NV, |
---|
| 3112 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 3113 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3114 | ELSE |
---|
| 3115 | CALL RD1020 ( X1, DX, A, NAUXV, V, MAXX1, NVPM, NV, |
---|
| 3116 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3117 | ENDIF |
---|
| 3118 | IF( IERR .EQ. 0 ) THEN |
---|
| 3119 | NIVM = NIVM + 1 |
---|
| 3120 | CALL L3RVAL ( X1, NIVM, RVAL, XIV0 ) |
---|
| 3121 | CALL TMON3 ( RVAL, MIN0(NIVM,3), DX, SUBFLG, NSF, |
---|
| 3122 | * 'X1', 2, NBAD, IOU ) |
---|
| 3123 | NDIAG = NDIAG + NBAD |
---|
| 3124 | TVAL(1) = XIV0 |
---|
| 3125 | TVAL(2) = RVAL(MIN0(3,NIVM)) |
---|
| 3126 | CALL TSTDX ( TVAL, MIN0(NIVM-1,2), (NIVM-1)*NVPM+1, DX, |
---|
| 3127 | * SUBFLG, NSF, 'X1', 2, NDIAG, IOU ) |
---|
| 3128 | ENDIF |
---|
| 3129 | RETURN |
---|
| 3130 | 2010 CONTINUE |
---|
| 3131 | IF( PARSIT ) THEN |
---|
| 3132 | CALL PD2010 ( X2, A, AMISS, NAUXV, V, VMISS, MAXX1, NX, NV, |
---|
| 3133 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 3134 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3135 | ELSE |
---|
| 3136 | CALL RD2010 ( X2, A, NAUXV, V, MAXX1, NX, NV, |
---|
| 3137 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3138 | ENDIF |
---|
| 3139 | CALL TRIVM ( X2, DX(2), RVAL, 'X2', 2, NIVM, XIV0, |
---|
| 3140 | * NDIAG, IOU, IERR ) |
---|
| 3141 | RETURN |
---|
| 3142 | 2110 CONTINUE |
---|
| 3143 | IF( PARSIT ) THEN |
---|
| 3144 | CALL PD2110 ( X1, X2, A, AMISS, NAUXV, V, VMISS, MAXX1, |
---|
| 3145 | * NX, NV, CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, |
---|
| 3146 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3147 | ELSE |
---|
| 3148 | CALL RD2110 ( X1, X2, A, AMISS, NAUXV, V, MAXX1, NX, NV, |
---|
| 3149 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3150 | ENDIF |
---|
| 3151 | CALL TRIVM ( X2, DX(2), RVAL, 'X2', 2, NIVM, XIV0, |
---|
| 3152 | * NDIAG, IOU, IERR ) |
---|
| 3153 | IF( NX(1) .GT. 0 .AND. NX(1) .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 3154 | CALL TMONO ( X1, NX, DX, SUBFLG, NSF, 'X1', 2, NBAD, IOU ) |
---|
| 3155 | NDIAG = NDIAG + NBAD |
---|
| 3156 | CALL TSTDX ( X1, NX, NX, DX, SUBFLG, NSF, 'X1', 2, NDIAG, IOU ) |
---|
| 3157 | ENDIF |
---|
| 3158 | RETURN |
---|
| 3159 | 2160 CONTINUE |
---|
| 3160 | IF( PARSIT ) THEN |
---|
| 3161 | CALL PD2160 ( X1, CX2, LENX, |
---|
| 3162 | * A, AMISS, NAUXV, CA, CAMISS, LENA, NAUXC, |
---|
| 3163 | * V, VMISS, MAXX1, NX, NV, |
---|
| 3164 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, |
---|
| 3165 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3166 | ELSE |
---|
| 3167 | CALL RD2160 ( X1, CX2, LENX, A, AMISS, CA, NAUXV, NAUXC, |
---|
| 3168 | * V, MAXX1, NX, NV, |
---|
| 3169 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3170 | ENDIF |
---|
| 3171 | CALL TCIVM ( CX2, LENX(2), CVAL, 'X2', 2, NIVM, |
---|
| 3172 | * NDIAG, IOU, IERR ) |
---|
| 3173 | IF( NX(1) .GT. 0 .AND. NX(1) .LT. INT(AMISS(1)+0.5) ) THEN |
---|
| 3174 | CALL TMONO ( X1, NX, DX, SUBFLG, NSF, 'X1', 2, NBAD, IOU ) |
---|
| 3175 | NDIAG = NDIAG + NBAD |
---|
| 3176 | CALL TSTDX ( X1, NX, NX, DX, SUBFLG, NSF, 'X1', 2, NDIAG, IOU ) |
---|
| 3177 | ENDIF |
---|
| 3178 | RETURN |
---|
| 3179 | 2310 CONTINUE |
---|
| 3180 | IF( PARSIT ) THEN |
---|
| 3181 | CALL PD2310 ( X2, A, AMISS, NAUXV, V, VMISS, X1, MAXX1, |
---|
| 3182 | * NX, NV, DX, |
---|
| 3183 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 3184 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3185 | ELSE |
---|
| 3186 | CALL RD2310 ( X2, A, AMISS, NAUXV, V, X1, MAXX1, NX, NV, DX, |
---|
| 3187 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3188 | ENDIF |
---|
| 3189 | CALL TRIVM ( X2, DX(2), RVAL, 'X2', 2, NIVM, XIV0, |
---|
| 3190 | * NDIAG, IOU, IERR ) |
---|
| 3191 | RETURN |
---|
| 3192 | 3010 CONTINUE |
---|
| 3193 | IF( PARSIT ) THEN |
---|
| 3194 | CALL PD3010 ( X3, A, AMISS, NAUXV, V, VMISS, MAXX1, NX, NV, |
---|
| 3195 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 3196 | * IUN, IOU, ISU, RETDAT, NDIAG, IERR ) |
---|
| 3197 | ELSE |
---|
| 3198 | CALL RD3010 ( X3, A, NAUXV, V, MAXX1, NX, NV, |
---|
| 3199 | * IUN, IOU, ISU, RETDAT, NDIAG, IERR ) |
---|
| 3200 | ENDIF |
---|
| 3201 | CALL TRIVM ( X3, DX(3), RVAL, 'X3', 2, NIVM, XIV0, |
---|
| 3202 | * NDIAG, IOU, IERR ) |
---|
| 3203 | RETURN |
---|
| 3204 | 4010 CONTINUE |
---|
| 3205 | IF( PARSIT ) THEN |
---|
| 3206 | CALL PD4010 ( X4, A, AMISS, NAUXV, V, VMISS, MAXX1, NX, NV, |
---|
| 3207 | * CDUM, DUM, LINE, NCIDR, NBIDR, NVALS, CRFMT, |
---|
| 3208 | * IUN, IOU, ISU, RETDAT, NDIAG, IERR ) |
---|
| 3209 | ELSE |
---|
| 3210 | CALL RD4010 ( X4, A, NAUXV, V, MAXX1, |
---|
| 3211 | * NX, NV, IUN, IOU, ISU, RETDAT, NDIAG, IERR ) |
---|
| 3212 | ENDIF |
---|
| 3213 | CALL TRIVM ( X4, DX(4), RVAL, 'X4', 2, NIVM, XIV0, |
---|
| 3214 | * NDIAG, IOU, IERR ) |
---|
| 3215 | RETURN |
---|
| 3216 | END |
---|
| 3217 | SUBROUTINE RH1001 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3218 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3219 | * DX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 3220 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 3221 | * MAXV, MAXCOM, CDUM, |
---|
| 3222 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3223 | C |
---|
| 3224 | C Subroutine to read file header for FFI=1010. |
---|
| 3225 | C IERR = 0 = successful read. |
---|
| 3226 | C = <0 = EOF encountered. |
---|
| 3227 | C = >0 = read error. |
---|
| 3228 | C |
---|
| 3229 | C History: |
---|
| 3230 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 3231 | C and TIXN routines, to `parse' numeric values in the |
---|
| 3232 | C file header records. |
---|
| 3233 | C |
---|
| 3234 | C Required routines: PARHD, RHBGIN, RHSTRN, TIXN. |
---|
| 3235 | C |
---|
| 3236 | C |
---|
| 3237 | CHARACTER*(*) CDUM |
---|
| 3238 | CHARACTER*(*) CRFMT |
---|
| 3239 | CHARACTER*(*) MNAME |
---|
| 3240 | CHARACTER*(*) NCOM( * ) |
---|
| 3241 | CHARACTER*(*) ONAME |
---|
| 3242 | CHARACTER*(*) ORG |
---|
| 3243 | CHARACTER*(*) SCOM( * ) |
---|
| 3244 | CHARACTER*(*) SNAME |
---|
| 3245 | CHARACTER*6 SUBFLG |
---|
| 3246 | CHARACTER*(*) VNAME( * ) |
---|
| 3247 | CHARACTER*(*) XNAME |
---|
| 3248 | C |
---|
| 3249 | DIMENSION VMISS( * ), VSCAL( * ) |
---|
| 3250 | C |
---|
| 3251 | DATA NSF / 6 / |
---|
| 3252 | DATA SUBFLG / 'RH1001' / |
---|
| 3253 | C |
---|
| 3254 | C |
---|
| 3255 | IERR = 0 |
---|
| 3256 | LINE = 0 |
---|
| 3257 | NCIDR= 0 |
---|
| 3258 | NBIDR= 0 |
---|
| 3259 | C |
---|
| 3260 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3261 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3262 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 3263 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3264 | IF( IERR .NE. 0 ) RETURN |
---|
| 3265 | C |
---|
| 3266 | CALL PARHD ( DX, 1, NFIND, SUBFLG, NSF, 'DX', 2, |
---|
| 3267 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3268 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3269 | IF( IERR .NE. 0 ) RETURN |
---|
| 3270 | C |
---|
| 3271 | CALL RHSTRN ( XNAME, 1, SUBFLG, NSF, 'XNAME', 5, |
---|
| 3272 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3273 | IF( IERR .NE. 0 ) RETURN |
---|
| 3274 | C |
---|
| 3275 | CALL PARHD ( RNV, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 3276 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3277 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3278 | IF( IERR .NE. 0 ) RETURN |
---|
| 3279 | NV = INT( RNV + 0.5 ) |
---|
| 3280 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 3281 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3282 | IF( IERR .NE. 0 ) RETURN |
---|
| 3283 | C |
---|
| 3284 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 3285 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3286 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3287 | IF( IERR .NE. 0 ) RETURN |
---|
| 3288 | DO 40 N=1,NV |
---|
| 3289 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 3290 | WRITE(IOU,*) ' **RH1001 error--VSCAL(N)=0, for N=', N |
---|
| 3291 | ENDIF |
---|
| 3292 | 40 CONTINUE |
---|
| 3293 | C |
---|
| 3294 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 3295 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3296 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3297 | IF( IERR .NE. 0 ) RETURN |
---|
| 3298 | C |
---|
| 3299 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 3300 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3301 | IF( IERR .NE. 0 ) RETURN |
---|
| 3302 | C |
---|
| 3303 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3304 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3305 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3306 | IF( IERR .NE. 0 ) RETURN |
---|
| 3307 | NSCOML = INT( DUM + 0.5 ) |
---|
| 3308 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3309 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3310 | IF( IERR .NE. 0 ) RETURN |
---|
| 3311 | C |
---|
| 3312 | IF( NSCOML .GT. 0 ) THEN |
---|
| 3313 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 3314 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3315 | IF( IERR .NE. 0 ) RETURN |
---|
| 3316 | ENDIF |
---|
| 3317 | C |
---|
| 3318 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 3319 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3320 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3321 | IF( IERR .NE. 0 ) RETURN |
---|
| 3322 | NNCOML = INT( DUM + 0.5 ) |
---|
| 3323 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 3324 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3325 | IF( IERR .NE. 0 ) RETURN |
---|
| 3326 | C |
---|
| 3327 | IF( NNCOML .GT. 0 ) THEN |
---|
| 3328 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 3329 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3330 | IF( IERR .NE. 0 ) RETURN |
---|
| 3331 | ENDIF |
---|
| 3332 | C |
---|
| 3333 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 3334 | WRITE(IOU,*) ' **RH1001 thinks NLHEAD may be in error' |
---|
| 3335 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 3336 | NDIAG = NDIAG + 1 |
---|
| 3337 | ENDIF |
---|
| 3338 | RETURN |
---|
| 3339 | END |
---|
| 3340 | SUBROUTINE RH1010 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3341 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3342 | * DX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 3343 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 3344 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 3345 | * MAXV, MAXA, MAXCOM, CDUM, |
---|
| 3346 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3347 | C |
---|
| 3348 | C Subroutine to read file header for FFI=1010. |
---|
| 3349 | C IERR = 0 = successful read. |
---|
| 3350 | C = <0 = EOF encountered. |
---|
| 3351 | C = >0 = read error. |
---|
| 3352 | C |
---|
| 3353 | C History: |
---|
| 3354 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 3355 | C and TIXN routines, to `parse' numeric values in the |
---|
| 3356 | C file header records. |
---|
| 3357 | C |
---|
| 3358 | C Required routines: PARHD, RHBGIN, RHSTRN, TIXN. |
---|
| 3359 | C |
---|
| 3360 | C |
---|
| 3361 | CHARACTER*(*) ANAME( * ) |
---|
| 3362 | CHARACTER*(*) CDUM |
---|
| 3363 | CHARACTER*(*) CRFMT |
---|
| 3364 | CHARACTER*(*) MNAME |
---|
| 3365 | CHARACTER*(*) NCOM( * ) |
---|
| 3366 | CHARACTER*(*) ONAME |
---|
| 3367 | CHARACTER*(*) ORG |
---|
| 3368 | CHARACTER*(*) SCOM( * ) |
---|
| 3369 | CHARACTER*(*) SNAME |
---|
| 3370 | CHARACTER*6 SUBFLG |
---|
| 3371 | CHARACTER*(*) VNAME( * ) |
---|
| 3372 | CHARACTER*(*) XNAME |
---|
| 3373 | C |
---|
| 3374 | DIMENSION AMISS( * ), ASCAL( * ) |
---|
| 3375 | DIMENSION VMISS( * ), VSCAL( * ) |
---|
| 3376 | C |
---|
| 3377 | DATA NSF / 6 / |
---|
| 3378 | DATA SUBFLG / 'RH1010' / |
---|
| 3379 | C |
---|
| 3380 | C |
---|
| 3381 | IERR = 0 |
---|
| 3382 | LINE = 0 |
---|
| 3383 | NCIDR = 0 |
---|
| 3384 | NBIDR = 0 |
---|
| 3385 | C |
---|
| 3386 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3387 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3388 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 3389 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3390 | IF( IERR .NE. 0 ) RETURN |
---|
| 3391 | C |
---|
| 3392 | CALL PARHD ( DX, 1, NFIND, SUBFLG, NSF, 'DX', 2, |
---|
| 3393 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3394 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3395 | IF( IERR .NE. 0 ) RETURN |
---|
| 3396 | C |
---|
| 3397 | CALL RHSTRN ( XNAME, 1, SUBFLG, NSF, 'XNAME', 5, |
---|
| 3398 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3399 | IF( IERR .NE. 0 ) RETURN |
---|
| 3400 | C |
---|
| 3401 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 3402 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3403 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3404 | IF( IERR .NE. 0 ) RETURN |
---|
| 3405 | NV = INT( DUM + 0.5 ) |
---|
| 3406 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 3407 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3408 | IF( IERR .NE. 0 ) RETURN |
---|
| 3409 | C |
---|
| 3410 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 3411 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3412 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3413 | IF( IERR .NE. 0 ) RETURN |
---|
| 3414 | DO 40 N=1,NV |
---|
| 3415 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 3416 | WRITE(IOU,*) ' **RH1010 error--VSCAL(N)=0, for N=', N |
---|
| 3417 | ENDIF |
---|
| 3418 | 40 CONTINUE |
---|
| 3419 | C |
---|
| 3420 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 3421 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3422 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3423 | IF( IERR .NE. 0 ) RETURN |
---|
| 3424 | C |
---|
| 3425 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 3426 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3427 | IF( IERR .NE. 0 ) RETURN |
---|
| 3428 | C |
---|
| 3429 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 3430 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3431 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3432 | IF( IERR .NE. 0 ) RETURN |
---|
| 3433 | NAUXV = INT( DUM + 0.5 ) |
---|
| 3434 | CALL TIXN ( NAUXV, 0, MAXA, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 3435 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3436 | IF( IERR .NE. 0 ) RETURN |
---|
| 3437 | C |
---|
| 3438 | IF( NAUXV .GT. 0 ) THEN |
---|
| 3439 | CALL PARHD ( ASCAL, NAUXV, NFIND, SUBFLG, NSF, 'ASCAL', 5, |
---|
| 3440 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3441 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3442 | IF( IERR .NE. 0 ) RETURN |
---|
| 3443 | DO 50 NA=1,NAUXV |
---|
| 3444 | IF( ASCAL(NA) .EQ. 0.0 ) THEN |
---|
| 3445 | WRITE(IOU,*) ' **RH1010 error--ASCAL(I)=0, for I=', NA |
---|
| 3446 | ENDIF |
---|
| 3447 | 50 CONTINUE |
---|
| 3448 | C |
---|
| 3449 | CALL PARHD ( AMISS, NAUXV, NFIND, SUBFLG, NSF, 'AMISS', 5, |
---|
| 3450 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3451 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3452 | IF( IERR .NE. 0 ) RETURN |
---|
| 3453 | C |
---|
| 3454 | CALL RHSTRN ( ANAME, NAUXV, SUBFLG, NSF, 'ANAME', 5, |
---|
| 3455 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3456 | IF( IERR .NE. 0 ) RETURN |
---|
| 3457 | ENDIF |
---|
| 3458 | C |
---|
| 3459 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3460 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3461 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3462 | IF( IERR .NE. 0 ) RETURN |
---|
| 3463 | NSCOML = INT( DUM + 0.5 ) |
---|
| 3464 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3465 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3466 | IF( IERR .NE. 0 ) RETURN |
---|
| 3467 | C |
---|
| 3468 | IF( NSCOML .GT. 0 ) THEN |
---|
| 3469 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 3470 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3471 | IF( IERR .NE. 0 ) RETURN |
---|
| 3472 | ENDIF |
---|
| 3473 | C |
---|
| 3474 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 3475 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3476 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3477 | IF( IERR .NE. 0 ) RETURN |
---|
| 3478 | NNCOML = INT( DUM + 0.5 ) |
---|
| 3479 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 3480 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3481 | IF( IERR .NE. 0 ) RETURN |
---|
| 3482 | C |
---|
| 3483 | IF( NNCOML .GT. 0 ) THEN |
---|
| 3484 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 3485 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3486 | IF( IERR .NE. 0 ) RETURN |
---|
| 3487 | ENDIF |
---|
| 3488 | C |
---|
| 3489 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 3490 | WRITE(IOU,*) ' **RH1010 thinks NLHEAD may be in error' |
---|
| 3491 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 3492 | NDIAG = NDIAG + 1 |
---|
| 3493 | ENDIF |
---|
| 3494 | RETURN |
---|
| 3495 | END |
---|
| 3496 | SUBROUTINE RH1020 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3497 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3498 | * DX, NVPM, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 3499 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 3500 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 3501 | * MAXX1, MAXV, MAXA, MAXCOM, CDUM, |
---|
| 3502 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3503 | C |
---|
| 3504 | C Subroutine to read file header for FFI=1020. |
---|
| 3505 | C IERR = 0 = successful read. |
---|
| 3506 | C = <0 = EOF encountered. |
---|
| 3507 | C = >0 = read error. |
---|
| 3508 | C |
---|
| 3509 | C History: |
---|
| 3510 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 3511 | C and TIXN routines, to `parse' numeric values in the |
---|
| 3512 | C file header records. |
---|
| 3513 | C |
---|
| 3514 | C Required routines: PARHD, RHBGIN, RHSTRN, TIXN. |
---|
| 3515 | C |
---|
| 3516 | C |
---|
| 3517 | CHARACTER*(*) ANAME( * ) |
---|
| 3518 | CHARACTER*(*) CDUM |
---|
| 3519 | CHARACTER*(*) CRFMT |
---|
| 3520 | CHARACTER*(*) MNAME |
---|
| 3521 | CHARACTER*(*) NCOM( * ) |
---|
| 3522 | CHARACTER*(*) ONAME |
---|
| 3523 | CHARACTER*(*) ORG |
---|
| 3524 | CHARACTER*(*) SCOM( * ) |
---|
| 3525 | CHARACTER*(*) SNAME |
---|
| 3526 | CHARACTER*6 SUBFLG |
---|
| 3527 | CHARACTER*(*) VNAME( * ) |
---|
| 3528 | CHARACTER*(*) XNAME |
---|
| 3529 | C |
---|
| 3530 | DIMENSION AMISS( * ), ASCAL( * ) |
---|
| 3531 | DIMENSION VMISS( * ), VSCAL( * ) |
---|
| 3532 | C |
---|
| 3533 | DATA NSF / 6 / |
---|
| 3534 | DATA SUBFLG / 'RH1020' / |
---|
| 3535 | C |
---|
| 3536 | C |
---|
| 3537 | IERR = 0 |
---|
| 3538 | LINE = 0 |
---|
| 3539 | NCIDR = 0 |
---|
| 3540 | NBIDR = 0 |
---|
| 3541 | C |
---|
| 3542 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3543 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3544 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 3545 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3546 | IF( IERR .NE. 0 ) RETURN |
---|
| 3547 | C |
---|
| 3548 | CALL PARHD ( DX, 1, NFIND, SUBFLG, NSF, 'DX', 2, |
---|
| 3549 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3550 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3551 | IF( IERR .NE. 0 ) RETURN |
---|
| 3552 | IF( DX .EQ. 0.0 ) THEN |
---|
| 3553 | WRITE(IOU,*) ' **RH1020 error, DX=0' |
---|
| 3554 | NDIAG = NDIAG + 1 |
---|
| 3555 | ENDIF |
---|
| 3556 | C |
---|
| 3557 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NVPM', 4, |
---|
| 3558 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3559 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3560 | IF( IERR .NE. 0 ) RETURN |
---|
| 3561 | NVPM = INT( DUM + 0.5 ) |
---|
| 3562 | CALL TIXN ( NVPM, 1, MAXX1, SUBFLG, NSF, 'NVPM', 4, |
---|
| 3563 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3564 | IF( IERR .NE. 0 ) RETURN |
---|
| 3565 | C |
---|
| 3566 | CALL RHSTRN ( XNAME, 1, SUBFLG, NSF, 'XNAME', 5, |
---|
| 3567 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3568 | IF( IERR .NE. 0 ) RETURN |
---|
| 3569 | C |
---|
| 3570 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 3571 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3572 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3573 | IF( IERR .NE. 0 ) RETURN |
---|
| 3574 | NV = INT( DUM + 0.5 ) |
---|
| 3575 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 3576 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3577 | IF( IERR .NE. 0 ) RETURN |
---|
| 3578 | C |
---|
| 3579 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 3580 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3581 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3582 | IF( IERR .NE. 0 ) RETURN |
---|
| 3583 | DO 40 N=1,NV |
---|
| 3584 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 3585 | WRITE(IOU,*) ' **RH1020 error--VSCAL(N)=0, for N=', N |
---|
| 3586 | ENDIF |
---|
| 3587 | 40 CONTINUE |
---|
| 3588 | C |
---|
| 3589 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 3590 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3591 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3592 | IF( IERR .NE. 0 ) RETURN |
---|
| 3593 | C |
---|
| 3594 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 3595 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3596 | IF( IERR .NE. 0 ) RETURN |
---|
| 3597 | C |
---|
| 3598 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 3599 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3600 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3601 | IF( IERR .NE. 0 ) RETURN |
---|
| 3602 | NAUXV = INT( DUM + 0.5 ) |
---|
| 3603 | CALL TIXN ( NAUXV, 0, MAXA, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 3604 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3605 | IF( IERR .NE. 0 ) RETURN |
---|
| 3606 | C |
---|
| 3607 | IF( NAUXV .GT. 0 ) THEN |
---|
| 3608 | CALL PARHD ( ASCAL, NAUXV, NFIND, SUBFLG, NSF, 'ASCAL', 5, |
---|
| 3609 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3610 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3611 | IF( IERR .NE. 0 ) RETURN |
---|
| 3612 | DO 50 NA=1,NAUXV |
---|
| 3613 | IF( ASCAL(NA) .EQ. 0.0 ) THEN |
---|
| 3614 | WRITE(IOU,*) ' **RH1020 error--ASCAL(I)=0, for I=', NA |
---|
| 3615 | ENDIF |
---|
| 3616 | 50 CONTINUE |
---|
| 3617 | C |
---|
| 3618 | CALL PARHD ( AMISS, NAUXV, NFIND, SUBFLG, NSF, 'AMISS', 5, |
---|
| 3619 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3620 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3621 | IF( IERR .NE. 0 ) RETURN |
---|
| 3622 | C |
---|
| 3623 | CALL RHSTRN ( ANAME, NAUXV, SUBFLG, NSF, 'ANAME', 5, |
---|
| 3624 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3625 | IF( IERR .NE. 0 ) RETURN |
---|
| 3626 | ENDIF |
---|
| 3627 | C |
---|
| 3628 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3629 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3630 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3631 | IF( IERR .NE. 0 ) RETURN |
---|
| 3632 | NSCOML = INT( DUM + 0.5 ) |
---|
| 3633 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3634 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3635 | IF( IERR .NE. 0 ) RETURN |
---|
| 3636 | C |
---|
| 3637 | IF( NSCOML .GT. 0 ) THEN |
---|
| 3638 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 3639 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3640 | IF( IERR .NE. 0 ) RETURN |
---|
| 3641 | ENDIF |
---|
| 3642 | C |
---|
| 3643 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 3644 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3645 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3646 | IF( IERR .NE. 0 ) RETURN |
---|
| 3647 | NNCOML = INT( DUM + 0.5 ) |
---|
| 3648 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 3649 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3650 | IF( IERR .NE. 0 ) RETURN |
---|
| 3651 | C |
---|
| 3652 | IF( NNCOML .GT. 0 ) THEN |
---|
| 3653 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 3654 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3655 | IF( IERR .NE. 0 ) RETURN |
---|
| 3656 | ENDIF |
---|
| 3657 | C |
---|
| 3658 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 3659 | WRITE(IOU,*) ' **RH1020 thinks NLHEAD may be in error' |
---|
| 3660 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 3661 | NDIAG = NDIAG + 1 |
---|
| 3662 | ENDIF |
---|
| 3663 | RETURN |
---|
| 3664 | END |
---|
| 3665 | SUBROUTINE RH2010 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3666 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3667 | * DX, NX, NXDEF, X1, XNAME, |
---|
| 3668 | * NV, VSCAL, VMISS, VNAME, |
---|
| 3669 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 3670 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 3671 | * MAXX1, MAXV, MAXA, MAXCOM, CDUM, |
---|
| 3672 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3673 | C |
---|
| 3674 | C Subroutine to read file header for FFI=2010. |
---|
| 3675 | C IERR = 0 = successful read. |
---|
| 3676 | C = <0 = EOF encountered. |
---|
| 3677 | C = >0 = read error. |
---|
| 3678 | C |
---|
| 3679 | C History: |
---|
| 3680 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 3681 | C and TIXN routines, to `parse' numeric values in the |
---|
| 3682 | C file header records. |
---|
| 3683 | C |
---|
| 3684 | C Required routines: PARHD, RHBGIN, RHSTRN, |
---|
| 3685 | C TIXN, TMONO, TSTDX. |
---|
| 3686 | C |
---|
| 3687 | C |
---|
| 3688 | CHARACTER*(*) ANAME( * ) |
---|
| 3689 | CHARACTER*(*) CDUM |
---|
| 3690 | CHARACTER*(*) CRFMT |
---|
| 3691 | CHARACTER*(*) MNAME |
---|
| 3692 | CHARACTER*(*) NCOM( * ) |
---|
| 3693 | CHARACTER*(*) ONAME |
---|
| 3694 | CHARACTER*(*) ORG |
---|
| 3695 | CHARACTER*(*) SCOM( * ) |
---|
| 3696 | CHARACTER*(*) SNAME |
---|
| 3697 | CHARACTER*6 SUBFLG |
---|
| 3698 | CHARACTER*(*) VNAME( * ) |
---|
| 3699 | CHARACTER*(*) XNAME( * ) |
---|
| 3700 | C |
---|
| 3701 | DIMENSION AMISS( * ), ASCAL( * ), DX( * ) |
---|
| 3702 | DIMENSION VMISS( * ), VSCAL( * ), X1( * ) |
---|
| 3703 | C |
---|
| 3704 | DATA NSF / 6 / |
---|
| 3705 | DATA SUBFLG / 'RH2010' / |
---|
| 3706 | C |
---|
| 3707 | C |
---|
| 3708 | IERR = 0 |
---|
| 3709 | LINE = 0 |
---|
| 3710 | NCIDR = 0 |
---|
| 3711 | NBIDR = 0 |
---|
| 3712 | C |
---|
| 3713 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3714 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3715 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 3716 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3717 | IF( IERR .NE. 0 ) RETURN |
---|
| 3718 | C |
---|
| 3719 | CALL PARHD ( DX, 2, NFIND, SUBFLG, NSF, 'DX', 2, |
---|
| 3720 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3721 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3722 | IF( IERR .NE. 0 ) RETURN |
---|
| 3723 | C |
---|
| 3724 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NX', 2, |
---|
| 3725 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3726 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3727 | IF( IERR .NE. 0 ) RETURN |
---|
| 3728 | NX = INT( DUM + 0.5 ) |
---|
| 3729 | CALL TIXN ( NX, 1, MAXX1, SUBFLG, NSF, 'NX', 2, |
---|
| 3730 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3731 | IF( IERR .NE. 0 ) RETURN |
---|
| 3732 | C |
---|
| 3733 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NXDEF', 5, |
---|
| 3734 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3735 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3736 | IF( IERR .NE. 0 ) RETURN |
---|
| 3737 | NXDEF = INT( DUM + 0.5 ) |
---|
| 3738 | CALL TIXN ( NXDEF, 1, NX, SUBFLG, NSF, 'NXDEF', 5, |
---|
| 3739 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3740 | IF( IERR .NE. 0 ) RETURN |
---|
| 3741 | IF( NXDEF .GT. 1 .AND. NXDEF .LT. NX ) THEN |
---|
| 3742 | WRITE( IOU,* ) ' ***RH2010 error--improper value for NXDEF' |
---|
| 3743 | WRITE( IOU,* ) ' MAXX1,NXDEF,NX(1)=', MAXX1, NXDEF, NX |
---|
| 3744 | IERR = 2 |
---|
| 3745 | NDIAG = NDIAG + 1 |
---|
| 3746 | RETURN |
---|
| 3747 | ENDIF |
---|
| 3748 | C |
---|
| 3749 | CALL PARHD ( X1, NXDEF, NFIND, SUBFLG, NSF, 'X1', 2, |
---|
| 3750 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3751 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3752 | IF( IERR .NE. 0 ) RETURN |
---|
| 3753 | IF( NXDEF .GT. 1 ) THEN |
---|
| 3754 | CALL TMONO ( X1, NXDEF, DX, SUBFLG, NSF, 'X1', 2, NBAD, IOU ) |
---|
| 3755 | NDIAG = NDIAG + NBAD |
---|
| 3756 | CALL TSTDX ( X1, NXDEF, NX, DX, SUBFLG, NSF, 'X1', 2, |
---|
| 3757 | * NDIAG, IOU ) |
---|
| 3758 | ELSE |
---|
| 3759 | IF( NX .GT. 1 .AND. DX(1) .EQ. 0.0 ) THEN |
---|
| 3760 | WRITE( IOU,* ) ' **RH2010 error--DX(1)=0 and NXDEF<NX' |
---|
| 3761 | WRITE( IOU,* ) ' X1(I) can not be properly defined' |
---|
| 3762 | WRITE( IOU,* ) ' NXDEF, NX =', NXDEF, NX |
---|
| 3763 | NDIAG = NDIAG + 1 |
---|
| 3764 | ENDIF |
---|
| 3765 | DO 26 I=2,NX |
---|
| 3766 | X1(I) = X1(1) + FLOAT( I-1 ) * DX(1) |
---|
| 3767 | 26 CONTINUE |
---|
| 3768 | ENDIF |
---|
| 3769 | C |
---|
| 3770 | CALL RHSTRN ( XNAME, 2, SUBFLG, NSF, 'XNAME', 5, |
---|
| 3771 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3772 | IF( IERR .NE. 0 ) RETURN |
---|
| 3773 | C |
---|
| 3774 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 3775 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3776 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3777 | IF( IERR .NE. 0 ) RETURN |
---|
| 3778 | NV = INT( DUM + 0.5 ) |
---|
| 3779 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 3780 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3781 | IF( IERR .NE. 0 ) RETURN |
---|
| 3782 | C |
---|
| 3783 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 3784 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3785 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3786 | IF( IERR .NE. 0 ) RETURN |
---|
| 3787 | DO 40 N=1,NV |
---|
| 3788 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 3789 | WRITE(IOU,*) ' **RH2010 error--VSCAL(N)=0, for N=', N |
---|
| 3790 | ENDIF |
---|
| 3791 | 40 CONTINUE |
---|
| 3792 | C |
---|
| 3793 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 3794 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3795 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3796 | IF( IERR .NE. 0 ) RETURN |
---|
| 3797 | C |
---|
| 3798 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 3799 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3800 | IF( IERR .NE. 0 ) RETURN |
---|
| 3801 | C |
---|
| 3802 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 3803 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3804 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3805 | IF( IERR .NE. 0 ) RETURN |
---|
| 3806 | NAUXV = INT( DUM + 0.5 ) |
---|
| 3807 | CALL TIXN ( NAUXV, 0, MAXA, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 3808 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3809 | IF( IERR .NE. 0 ) RETURN |
---|
| 3810 | C |
---|
| 3811 | IF( NAUXV .GT. 0 ) THEN |
---|
| 3812 | CALL PARHD ( ASCAL, NAUXV, NFIND, SUBFLG, NSF, 'ASCAL', 5, |
---|
| 3813 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3814 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3815 | IF( IERR .NE. 0 ) RETURN |
---|
| 3816 | DO 50 NA=1,NAUXV |
---|
| 3817 | IF( ASCAL(NA) .EQ. 0.0 ) THEN |
---|
| 3818 | WRITE(IOU,*) ' **RH2010 error--ASCAL(I)=0, for I=', NA |
---|
| 3819 | ENDIF |
---|
| 3820 | 50 CONTINUE |
---|
| 3821 | C |
---|
| 3822 | CALL PARHD ( AMISS, NAUXV, NFIND, SUBFLG, NSF, 'AMISS', 5, |
---|
| 3823 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3824 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3825 | IF( IERR .NE. 0 ) RETURN |
---|
| 3826 | C |
---|
| 3827 | CALL RHSTRN ( ANAME, NAUXV, SUBFLG, NSF, 'ANAME', 5, |
---|
| 3828 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3829 | IF( IERR .NE. 0 ) RETURN |
---|
| 3830 | ENDIF |
---|
| 3831 | C |
---|
| 3832 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3833 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3834 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3835 | IF( IERR .NE. 0 ) RETURN |
---|
| 3836 | NSCOML = INT( DUM + 0.5 ) |
---|
| 3837 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3838 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3839 | IF( IERR .NE. 0 ) RETURN |
---|
| 3840 | C |
---|
| 3841 | IF( NSCOML .GT. 0 ) THEN |
---|
| 3842 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 3843 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3844 | IF( IERR .NE. 0 ) RETURN |
---|
| 3845 | ENDIF |
---|
| 3846 | C |
---|
| 3847 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 3848 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3849 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3850 | IF( IERR .NE. 0 ) RETURN |
---|
| 3851 | NNCOML = INT( DUM + 0.5 ) |
---|
| 3852 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 3853 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3854 | IF( IERR .NE. 0 ) RETURN |
---|
| 3855 | C |
---|
| 3856 | IF( NNCOML .GT. 0 ) THEN |
---|
| 3857 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 3858 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3859 | IF( IERR .NE. 0 ) RETURN |
---|
| 3860 | ENDIF |
---|
| 3861 | C |
---|
| 3862 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 3863 | WRITE(IOU,*) ' **RH2010 thinks NLHEAD may be in error' |
---|
| 3864 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 3865 | NDIAG = NDIAG + 1 |
---|
| 3866 | ENDIF |
---|
| 3867 | RETURN |
---|
| 3868 | END |
---|
| 3869 | SUBROUTINE RH2110 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3870 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3871 | * DX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 3872 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 3873 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 3874 | * MAXV, MAXA, MAXCOM, CDUM, |
---|
| 3875 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3876 | C |
---|
| 3877 | C Subroutine to read file header for FFI=2110. |
---|
| 3878 | C IERR = 0 = successful read. |
---|
| 3879 | C = <0 = EOF encountered. |
---|
| 3880 | C = >0 = read error. |
---|
| 3881 | C |
---|
| 3882 | C History: |
---|
| 3883 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 3884 | C and TIXN routines, to `parse' numeric values in the |
---|
| 3885 | C file header records. |
---|
| 3886 | C |
---|
| 3887 | C Required routines: PARHD, RHBGIN, RHSTRN, TIXN. |
---|
| 3888 | C |
---|
| 3889 | C |
---|
| 3890 | CHARACTER*(*) ANAME( * ) |
---|
| 3891 | CHARACTER*(*) CDUM |
---|
| 3892 | CHARACTER*(*) CRFMT |
---|
| 3893 | CHARACTER*(*) MNAME |
---|
| 3894 | CHARACTER*(*) NCOM( * ) |
---|
| 3895 | CHARACTER*(*) ONAME |
---|
| 3896 | CHARACTER*(*) ORG |
---|
| 3897 | CHARACTER*(*) SCOM( * ) |
---|
| 3898 | CHARACTER*(*) SNAME |
---|
| 3899 | CHARACTER*6 SUBFLG |
---|
| 3900 | CHARACTER*(*) VNAME( * ) |
---|
| 3901 | CHARACTER*(*) XNAME( * ) |
---|
| 3902 | C |
---|
| 3903 | DIMENSION AMISS( * ), ASCAL( * ), DX( * ) |
---|
| 3904 | DIMENSION VMISS( * ), VSCAL( * ) |
---|
| 3905 | C |
---|
| 3906 | DATA NSF / 6 / |
---|
| 3907 | DATA SUBFLG / 'RH2110' / |
---|
| 3908 | C |
---|
| 3909 | C |
---|
| 3910 | IERR = 0 |
---|
| 3911 | LINE = 0 |
---|
| 3912 | NCIDR = 0 |
---|
| 3913 | NBIDR = 0 |
---|
| 3914 | C |
---|
| 3915 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 3916 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 3917 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 3918 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3919 | IF( IERR .NE. 0 ) RETURN |
---|
| 3920 | C |
---|
| 3921 | CALL PARHD ( DX, 2, NFIND, SUBFLG, NSF, 'DX', 2, |
---|
| 3922 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3923 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3924 | IF( IERR .NE. 0 ) RETURN |
---|
| 3925 | C |
---|
| 3926 | CALL RHSTRN ( XNAME, 2, SUBFLG, NSF, 'XNAME', 5, |
---|
| 3927 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3928 | IF( IERR .NE. 0 ) RETURN |
---|
| 3929 | C |
---|
| 3930 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 3931 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3932 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3933 | IF( IERR .NE. 0 ) RETURN |
---|
| 3934 | NV = INT( DUM + 0.5 ) |
---|
| 3935 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 3936 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3937 | IF( IERR .NE. 0 ) RETURN |
---|
| 3938 | C |
---|
| 3939 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 3940 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3941 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3942 | IF( IERR .NE. 0 ) RETURN |
---|
| 3943 | DO 40 N=1,NV |
---|
| 3944 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 3945 | WRITE(IOU,*) ' **RH2110 error--VSCAL(N)=0, for N=', N |
---|
| 3946 | ENDIF |
---|
| 3947 | 40 CONTINUE |
---|
| 3948 | C |
---|
| 3949 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 3950 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3951 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3952 | IF( IERR .NE. 0 ) RETURN |
---|
| 3953 | C |
---|
| 3954 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 3955 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3956 | IF( IERR .NE. 0 ) RETURN |
---|
| 3957 | C |
---|
| 3958 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 3959 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3960 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3961 | IF( IERR .NE. 0 ) RETURN |
---|
| 3962 | NAUXV = INT( DUM + 0.5 ) |
---|
| 3963 | CALL TIXN ( NAUXV, 1, MAXA, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 3964 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3965 | IF( IERR .NE. 0 ) RETURN |
---|
| 3966 | C |
---|
| 3967 | CALL PARHD ( ASCAL, NAUXV, NFIND, SUBFLG, NSF, 'ASCAL', 5, |
---|
| 3968 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3969 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3970 | IF( IERR .NE. 0 ) RETURN |
---|
| 3971 | DO 50 NA=1,NAUXV |
---|
| 3972 | IF( ASCAL(NA) .EQ. 0.0 ) THEN |
---|
| 3973 | WRITE(IOU,*) ' **RH2110 error--ASCAL(I)=0, for I=', NA |
---|
| 3974 | ENDIF |
---|
| 3975 | 50 CONTINUE |
---|
| 3976 | C |
---|
| 3977 | CALL PARHD ( AMISS, NAUXV, NFIND, SUBFLG, NSF, 'AMISS', 5, |
---|
| 3978 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3979 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3980 | IF( IERR .NE. 0 ) RETURN |
---|
| 3981 | C |
---|
| 3982 | CALL RHSTRN ( ANAME, NAUXV, SUBFLG, NSF, 'ANAME', 5, |
---|
| 3983 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3984 | IF( IERR .NE. 0 ) RETURN |
---|
| 3985 | C |
---|
| 3986 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3987 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 3988 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3989 | IF( IERR .NE. 0 ) RETURN |
---|
| 3990 | NSCOML = INT( DUM + 0.5 ) |
---|
| 3991 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 3992 | * IUN, IOU, NDIAG, IERR ) |
---|
| 3993 | IF( IERR .NE. 0 ) RETURN |
---|
| 3994 | C |
---|
| 3995 | IF( NSCOML .GT. 0 ) THEN |
---|
| 3996 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 3997 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 3998 | IF( IERR .NE. 0 ) RETURN |
---|
| 3999 | ENDIF |
---|
| 4000 | C |
---|
| 4001 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4002 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4003 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4004 | IF( IERR .NE. 0 ) RETURN |
---|
| 4005 | NNCOML = INT( DUM + 0.5 ) |
---|
| 4006 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4007 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4008 | IF( IERR .NE. 0 ) RETURN |
---|
| 4009 | C |
---|
| 4010 | IF( NNCOML .GT. 0 ) THEN |
---|
| 4011 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 4012 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4013 | IF( IERR .NE. 0 ) RETURN |
---|
| 4014 | ENDIF |
---|
| 4015 | C |
---|
| 4016 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 4017 | WRITE(IOU,*) ' **RH2110 thinks NLHEAD may be in error' |
---|
| 4018 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 4019 | NDIAG = NDIAG + 1 |
---|
| 4020 | ENDIF |
---|
| 4021 | RETURN |
---|
| 4022 | END |
---|
| 4023 | SUBROUTINE RH2160 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4024 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4025 | * DX, LENX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 4026 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 4027 | * NAUXC, LENA, CAMISS, DUMLEN, |
---|
| 4028 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 4029 | * MAXV, MAXA, MAXCA, MAXCOM, MAXCPL, CDUM, |
---|
| 4030 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4031 | C |
---|
| 4032 | C Subroutine to read file header for FFI=2160. |
---|
| 4033 | C IERR = 0 = successful read. |
---|
| 4034 | C = <0 = EOF encountered. |
---|
| 4035 | C = >0 = read error. |
---|
| 4036 | C |
---|
| 4037 | C History: |
---|
| 4038 | C 93-03-11 - Added code to test for NAUXV+NAUXC > MAXA. |
---|
| 4039 | C |
---|
| 4040 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 4041 | C and TIXN routines, to `parse' numeric values in the |
---|
| 4042 | C file header records. |
---|
| 4043 | C |
---|
| 4044 | C Required routines: PARHD, RHBGIN, RHSTRN, TIXN. |
---|
| 4045 | C |
---|
| 4046 | C |
---|
| 4047 | CHARACTER*(*) ANAME( * ) |
---|
| 4048 | CHARACTER*(*) CAMISS( * ) |
---|
| 4049 | CHARACTER*(*) CDUM |
---|
| 4050 | CHARACTER*(*) CRFMT |
---|
| 4051 | CHARACTER*(*) MNAME |
---|
| 4052 | CHARACTER*(*) NCOM( * ) |
---|
| 4053 | CHARACTER*(*) ONAME |
---|
| 4054 | CHARACTER*(*) ORG |
---|
| 4055 | CHARACTER*(*) SCOM( * ) |
---|
| 4056 | CHARACTER*(*) SNAME |
---|
| 4057 | CHARACTER*6 SUBFLG |
---|
| 4058 | CHARACTER*(*) VNAME( * ) |
---|
| 4059 | CHARACTER*(*) XNAME( * ) |
---|
| 4060 | C |
---|
| 4061 | DIMENSION AMISS( * ), ASCAL( * ), LENA( * ), DUMLEN( * ) |
---|
| 4062 | DIMENSION VMISS( * ), VSCAL( * ), LENX( * ) |
---|
| 4063 | C |
---|
| 4064 | DATA NSF / 6 / |
---|
| 4065 | DATA SUBFLG / 'RH2160' / |
---|
| 4066 | C |
---|
| 4067 | C |
---|
| 4068 | IERR = 0 |
---|
| 4069 | LINE = 0 |
---|
| 4070 | NCIDR = 0 |
---|
| 4071 | NBIDR = 0 |
---|
| 4072 | C |
---|
| 4073 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4074 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4075 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 4076 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4077 | IF( IERR .NE. 0 ) RETURN |
---|
| 4078 | C |
---|
| 4079 | CALL PARHD ( DX, 1, NFIND, SUBFLG, NSF, 'DX', 2, |
---|
| 4080 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4081 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4082 | IF( IERR .NE. 0 ) RETURN |
---|
| 4083 | C |
---|
| 4084 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'LENX(2)', 7, |
---|
| 4085 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4086 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4087 | IF( IERR .NE. 0 ) RETURN |
---|
| 4088 | LENX(2) = INT( DUM + 0.5 ) |
---|
| 4089 | CALL TIXN ( LENX(2), 1, MAXCPL, SUBFLG, NSF, 'LENX(2)', 7, |
---|
| 4090 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4091 | IF( IERR .NE. 0 ) RETURN |
---|
| 4092 | C |
---|
| 4093 | CALL RHSTRN ( XNAME, 2, SUBFLG, NSF, 'XNAME', 5, |
---|
| 4094 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4095 | IF( IERR .NE. 0 ) RETURN |
---|
| 4096 | C |
---|
| 4097 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 4098 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4099 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4100 | IF( IERR .NE. 0 ) RETURN |
---|
| 4101 | NV = INT( DUM + 0.5 ) |
---|
| 4102 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 4103 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4104 | IF( IERR .NE. 0 ) RETURN |
---|
| 4105 | C |
---|
| 4106 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 4107 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4108 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4109 | IF( IERR .NE. 0 ) RETURN |
---|
| 4110 | DO 40 N=1,NV |
---|
| 4111 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 4112 | WRITE(IOU,*) ' **RH2160 error--VSCAL(N)=0, for N=', N |
---|
| 4113 | ENDIF |
---|
| 4114 | 40 CONTINUE |
---|
| 4115 | C |
---|
| 4116 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 4117 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4118 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4119 | IF( IERR .NE. 0 ) RETURN |
---|
| 4120 | C |
---|
| 4121 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 4122 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4123 | IF( IERR .NE. 0 ) RETURN |
---|
| 4124 | C |
---|
| 4125 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 4126 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4127 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4128 | IF( IERR .NE. 0 ) RETURN |
---|
| 4129 | NAUXV = INT( DUM + 0.5 ) |
---|
| 4130 | CALL TIXN ( NAUXV, 1, MAXA, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 4131 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4132 | IF( IERR .NE. 0 ) RETURN |
---|
| 4133 | C |
---|
| 4134 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXC', 5, |
---|
| 4135 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4136 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4137 | IF( IERR .NE. 0 ) RETURN |
---|
| 4138 | NAUXC = INT( DUM + 0.5 ) |
---|
| 4139 | CALL TIXN ( NAUXC, 0, MAXCA, SUBFLG, NSF, 'NAUXC', 5, |
---|
| 4140 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4141 | IF( IERR .NE. 0 ) RETURN |
---|
| 4142 | C |
---|
| 4143 | c CALL TIXN ( NAUXV+NAUXC, 0, MAXA, SUBFLG, NSF, 'NAUXV+NAUXC', 11, |
---|
| 4144 | c * IUN, IOU, NDIAG, IERR ) |
---|
| 4145 | c IF( IERR .NE. 0 ) RETURN |
---|
| 4146 | C |
---|
| 4147 | CALL PARHD ( ASCAL, NAUXV-NAUXC, NFIND, SUBFLG, NSF, 'ASCAL', 5, |
---|
| 4148 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4149 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4150 | IF( IERR .NE. 0 ) RETURN |
---|
| 4151 | DO 50 NA=1,NAUXV-NAUXC |
---|
| 4152 | IF( ASCAL(NA) .EQ. 0.0 ) THEN |
---|
| 4153 | WRITE(IOU,*) ' **RH2160 error--ASCAL(I)=0, for I=', NA |
---|
| 4154 | ENDIF |
---|
| 4155 | 50 CONTINUE |
---|
| 4156 | C |
---|
| 4157 | CALL PARHD ( AMISS, NAUXV-NAUXC, NFIND, SUBFLG, NSF, 'AMISS', 5, |
---|
| 4158 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4159 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4160 | IF( IERR .NE. 0 ) RETURN |
---|
| 4161 | C |
---|
| 4162 | IF( NAUXC .GT. 0 ) THEN |
---|
| 4163 | CALL PARHD ( DUMLEN, NAUXC, NFIND, SUBFLG, NSF, 'LENA', 4, |
---|
| 4164 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4165 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4166 | IF( IERR .NE. 0 ) RETURN |
---|
| 4167 | C |
---|
| 4168 | DO 72 IC=1,NAUXC |
---|
| 4169 | LENA(IC) = INT( DUMLEN(IC) + 0.5 ) |
---|
| 4170 | IF( LENA(IC) .LT. 1 .OR. LENA(IC) .GT. MAXCPL ) THEN |
---|
| 4171 | WRITE( IOU,* ) ' ***RH2160 error--improper LENA', IC |
---|
| 4172 | WRITE( IOU,* ) ' MAXCPL,LENA(IC)=', MAXCPL, LENA(IC) |
---|
| 4173 | IERR = 2 |
---|
| 4174 | NDIAG = NDIAG + 1 |
---|
| 4175 | RETURN |
---|
| 4176 | ENDIF |
---|
| 4177 | 72 CONTINUE |
---|
| 4178 | C |
---|
| 4179 | CALL RHSTRN ( CAMISS, NAUXC, SUBFLG, NSF, 'CAMISS', 6, |
---|
| 4180 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4181 | IF( IERR .NE. 0 ) RETURN |
---|
| 4182 | ENDIF |
---|
| 4183 | C |
---|
| 4184 | CALL RHSTRN ( ANAME, NAUXV, SUBFLG, NSF, 'ANAME', 5, |
---|
| 4185 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4186 | IF( IERR .NE. 0 ) RETURN |
---|
| 4187 | C |
---|
| 4188 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 4189 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4190 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4191 | IF( IERR .NE. 0 ) RETURN |
---|
| 4192 | NSCOML = INT( DUM + 0.5 ) |
---|
| 4193 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 4194 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4195 | IF( IERR .NE. 0 ) RETURN |
---|
| 4196 | C |
---|
| 4197 | IF( NSCOML .GT. 0 ) THEN |
---|
| 4198 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 4199 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4200 | IF( IERR .NE. 0 ) RETURN |
---|
| 4201 | ENDIF |
---|
| 4202 | C |
---|
| 4203 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4204 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4205 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4206 | IF( IERR .NE. 0 ) RETURN |
---|
| 4207 | NNCOML = INT( DUM + 0.5 ) |
---|
| 4208 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4209 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4210 | IF( IERR .NE. 0 ) RETURN |
---|
| 4211 | C |
---|
| 4212 | IF( NNCOML .GT. 0 ) THEN |
---|
| 4213 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 4214 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4215 | IF( IERR .NE. 0 ) RETURN |
---|
| 4216 | ENDIF |
---|
| 4217 | C |
---|
| 4218 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 4219 | WRITE(IOU,*) ' **RH2160 thinks NLHEAD may be in error' |
---|
| 4220 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 4221 | NDIAG = NDIAG + 1 |
---|
| 4222 | ENDIF |
---|
| 4223 | RETURN |
---|
| 4224 | END |
---|
| 4225 | SUBROUTINE RH2310 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4226 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4227 | * DX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 4228 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 4229 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 4230 | * MAXV, MAXA, MAXCOM, CDUM, |
---|
| 4231 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4232 | C |
---|
| 4233 | C Subroutine to read file header for FFI=2310. |
---|
| 4234 | C IERR = 0 = successful read. |
---|
| 4235 | C = <0 = EOF encountered. |
---|
| 4236 | C = >0 = read error. |
---|
| 4237 | C |
---|
| 4238 | C History: |
---|
| 4239 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 4240 | C and TIXN routines, to `parse' numeric values in the |
---|
| 4241 | C file header records. |
---|
| 4242 | C |
---|
| 4243 | C Required routines: PARHD, RHBGIN, RHSTRN, TIXN. |
---|
| 4244 | C |
---|
| 4245 | C |
---|
| 4246 | CHARACTER*(*) ANAME( * ) |
---|
| 4247 | CHARACTER*(*) CDUM |
---|
| 4248 | CHARACTER*(*) CRFMT |
---|
| 4249 | CHARACTER*(*) MNAME |
---|
| 4250 | CHARACTER*(*) NCOM( * ) |
---|
| 4251 | CHARACTER*(*) ONAME |
---|
| 4252 | CHARACTER*(*) ORG |
---|
| 4253 | CHARACTER*(*) SCOM( * ) |
---|
| 4254 | CHARACTER*(*) SNAME |
---|
| 4255 | CHARACTER*6 SUBFLG |
---|
| 4256 | CHARACTER*(*) VNAME( * ) |
---|
| 4257 | CHARACTER*(*) XNAME( * ) |
---|
| 4258 | C |
---|
| 4259 | DIMENSION AMISS( * ), ASCAL( * ), DX( * ) |
---|
| 4260 | DIMENSION VMISS( * ), VSCAL( * ) |
---|
| 4261 | C |
---|
| 4262 | DATA NSF / 6 / |
---|
| 4263 | DATA SUBFLG / 'RH2310' / |
---|
| 4264 | C |
---|
| 4265 | C |
---|
| 4266 | IERR = 0 |
---|
| 4267 | LINE = 0 |
---|
| 4268 | NCIDR = 0 |
---|
| 4269 | NBIDR = 0 |
---|
| 4270 | C |
---|
| 4271 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4272 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4273 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 4274 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4275 | IF( IERR .NE. 0 ) RETURN |
---|
| 4276 | C |
---|
| 4277 | CALL PARHD ( DX(2), 1, NFIND, SUBFLG, NSF, 'DX(2)', 5, |
---|
| 4278 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4279 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4280 | IF( IERR .NE. 0 ) RETURN |
---|
| 4281 | C |
---|
| 4282 | CALL RHSTRN ( XNAME, 2, SUBFLG, NSF, 'XNAME', 5, |
---|
| 4283 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4284 | IF( IERR .NE. 0 ) RETURN |
---|
| 4285 | C |
---|
| 4286 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 4287 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4288 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4289 | IF( IERR .NE. 0 ) RETURN |
---|
| 4290 | NV = INT( DUM + 0.5 ) |
---|
| 4291 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 4292 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4293 | IF( IERR .NE. 0 ) RETURN |
---|
| 4294 | C |
---|
| 4295 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 4296 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4297 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4298 | IF( IERR .NE. 0 ) RETURN |
---|
| 4299 | DO 40 N=1,NV |
---|
| 4300 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 4301 | WRITE(IOU,*) ' **RH2310 error--VSCAL(N)=0, for N=', N |
---|
| 4302 | ENDIF |
---|
| 4303 | 40 CONTINUE |
---|
| 4304 | C |
---|
| 4305 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 4306 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4307 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4308 | IF( IERR .NE. 0 ) RETURN |
---|
| 4309 | C |
---|
| 4310 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 4311 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4312 | IF( IERR .NE. 0 ) RETURN |
---|
| 4313 | C |
---|
| 4314 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 4315 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4316 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4317 | IF( IERR .NE. 0 ) RETURN |
---|
| 4318 | NAUXV = INT( DUM + 0.5 ) |
---|
| 4319 | CALL TIXN ( NAUXV, 3, MAXA, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 4320 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4321 | IF( IERR .NE. 0 ) RETURN |
---|
| 4322 | C |
---|
| 4323 | CALL PARHD ( ASCAL, NAUXV, NFIND, SUBFLG, NSF, 'ASCAL', 5, |
---|
| 4324 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4325 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4326 | IF( IERR .NE. 0 ) RETURN |
---|
| 4327 | DO 50 NA=1,NAUXV |
---|
| 4328 | IF( ASCAL(NA) .EQ. 0.0 ) THEN |
---|
| 4329 | WRITE(IOU,*) ' **RH2310 error--ASCAL(I)=0, for I=', NA |
---|
| 4330 | ENDIF |
---|
| 4331 | 50 CONTINUE |
---|
| 4332 | C |
---|
| 4333 | CALL PARHD ( AMISS, NAUXV, NFIND, SUBFLG, NSF, 'AMISS', 5, |
---|
| 4334 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4335 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4336 | IF( IERR .NE. 0 ) RETURN |
---|
| 4337 | C |
---|
| 4338 | CALL RHSTRN ( ANAME, NAUXV, SUBFLG, NSF, 'ANAME', 5, |
---|
| 4339 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4340 | IF( IERR .NE. 0 ) RETURN |
---|
| 4341 | C |
---|
| 4342 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 4343 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4344 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4345 | IF( IERR .NE. 0 ) RETURN |
---|
| 4346 | NSCOML = INT( DUM + 0.5 ) |
---|
| 4347 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 4348 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4349 | IF( IERR .NE. 0 ) RETURN |
---|
| 4350 | C |
---|
| 4351 | IF( NSCOML .GT. 0 ) THEN |
---|
| 4352 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 4353 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4354 | IF( IERR .NE. 0 ) RETURN |
---|
| 4355 | ENDIF |
---|
| 4356 | C |
---|
| 4357 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4358 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4359 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4360 | IF( IERR .NE. 0 ) RETURN |
---|
| 4361 | NNCOML = INT( DUM + 0.5 ) |
---|
| 4362 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4363 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4364 | IF( IERR .NE. 0 ) RETURN |
---|
| 4365 | C |
---|
| 4366 | IF( NNCOML .GT. 0 ) THEN |
---|
| 4367 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 4368 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4369 | IF( IERR .NE. 0 ) RETURN |
---|
| 4370 | ENDIF |
---|
| 4371 | C |
---|
| 4372 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 4373 | WRITE(IOU,*) ' **RH2310 thinks NLHEAD may be in error' |
---|
| 4374 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 4375 | NDIAG = NDIAG + 1 |
---|
| 4376 | ENDIF |
---|
| 4377 | RETURN |
---|
| 4378 | END |
---|
| 4379 | SUBROUTINE RH3010 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4380 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4381 | * DX, NX, NXDEF, X1, X2, XNAME, |
---|
| 4382 | * NV, VSCAL, VMISS, VNAME, |
---|
| 4383 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 4384 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 4385 | * MAXX1, MAXX2, MAXV, MAXA, MAXCOM, CDUM, |
---|
| 4386 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4387 | C |
---|
| 4388 | C Subroutine to read file header for FFI=3010. |
---|
| 4389 | C IERR = 0 = successful read. |
---|
| 4390 | C = <0 = EOF encountered. |
---|
| 4391 | C = >0 = read error. |
---|
| 4392 | C |
---|
| 4393 | C History: |
---|
| 4394 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 4395 | C and TIXN routines, to `parse' numeric values in the |
---|
| 4396 | C file header records. |
---|
| 4397 | C |
---|
| 4398 | C Required routines: PARHD, RHBGIN, RHSTRN, |
---|
| 4399 | C TIXN, TMONO, TSTDX. |
---|
| 4400 | C |
---|
| 4401 | C |
---|
| 4402 | CHARACTER*(*) ANAME( * ) |
---|
| 4403 | CHARACTER*(*) CDUM |
---|
| 4404 | CHARACTER*(*) CRFMT |
---|
| 4405 | CHARACTER*(*) MNAME |
---|
| 4406 | CHARACTER*(*) NCOM( * ) |
---|
| 4407 | CHARACTER*(*) ONAME |
---|
| 4408 | CHARACTER*(*) ORG |
---|
| 4409 | CHARACTER*(*) SCOM( * ) |
---|
| 4410 | CHARACTER*(*) SNAME |
---|
| 4411 | CHARACTER*6 SUBFLG |
---|
| 4412 | CHARACTER*(*) VNAME( * ) |
---|
| 4413 | CHARACTER*(*) XNAME( * ) |
---|
| 4414 | C |
---|
| 4415 | DIMENSION AMISS( * ), ASCAL( * ), DX( * ), NXDEF( * ), NX( * ) |
---|
| 4416 | DIMENSION VMISS( * ), VSCAL( * ), X1( * ), X2( * ) |
---|
| 4417 | C |
---|
| 4418 | DATA NSF / 6 / |
---|
| 4419 | DATA SUBFLG / 'RH3010' / |
---|
| 4420 | C |
---|
| 4421 | C |
---|
| 4422 | IERR = 0 |
---|
| 4423 | LINE = 0 |
---|
| 4424 | NCIDR = 0 |
---|
| 4425 | NBIDR = 0 |
---|
| 4426 | C |
---|
| 4427 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4428 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4429 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 4430 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4431 | IF( IERR .NE. 0 ) RETURN |
---|
| 4432 | C |
---|
| 4433 | CALL PARHD ( DX, 3, NFIND, SUBFLG, NSF, 'DX', 2, |
---|
| 4434 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4435 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4436 | IF( IERR .NE. 0 ) RETURN |
---|
| 4437 | C |
---|
| 4438 | CALL PARHD ( VSCAL, 2, NFIND, SUBFLG, NSF, 'NX', 2, |
---|
| 4439 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4440 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4441 | IF( IERR .NE. 0 ) RETURN |
---|
| 4442 | NX(1) = INT( VSCAL(1) + 0.5 ) |
---|
| 4443 | NX(2) = INT( VSCAL(2) + 0.5 ) |
---|
| 4444 | CALL TIXN ( NX(1), 1, MAXX1, SUBFLG, NSF, 'NX(1)', 5, |
---|
| 4445 | * IUN, IOU, NDIAG, IER1 ) |
---|
| 4446 | CALL TIXN ( NX(2), 1, MAXX2, SUBFLG, NSF, 'NX(2)', 5, |
---|
| 4447 | * IUN, IOU, NDIAG, IER2 ) |
---|
| 4448 | IF( IER1+IER2 .NE. 0 ) RETURN |
---|
| 4449 | C |
---|
| 4450 | CALL PARHD ( VSCAL, 2, NFIND, SUBFLG, NSF, 'NXDEF', 5, |
---|
| 4451 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4452 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4453 | IF( IERR .NE. 0 ) RETURN |
---|
| 4454 | NXDEF(1) = INT( VSCAL(1) + 0.5 ) |
---|
| 4455 | NXDEF(2) = INT( VSCAL(2) + 0.5 ) |
---|
| 4456 | MAXX = MAXX1 |
---|
| 4457 | DO 22 N=1,2 |
---|
| 4458 | IF( NXDEF(N) .LT. 1 .OR. NXDEF(N) .GT. NX(N) .OR. |
---|
| 4459 | * (NXDEF(N) .GT. 1 .AND. NXDEF(N) .LT. NX(N)) ) THEN |
---|
| 4460 | WRITE( IOU,* ) |
---|
| 4461 | * ' ***RH3010 error--improper value for NXDEF',N |
---|
| 4462 | WRITE( IOU,* ) ' MAXX,NXDEF,NX=', MAXX, NXDEF(N), NX(N) |
---|
| 4463 | IERR = 2 |
---|
| 4464 | NDIAG = NDIAG + 1 |
---|
| 4465 | RETURN |
---|
| 4466 | ENDIF |
---|
| 4467 | MAXX = MAXX2 |
---|
| 4468 | 22 CONTINUE |
---|
| 4469 | C |
---|
| 4470 | CALL PARHD ( X1, NXDEF(1), NFIND, SUBFLG, NSF, 'X1', 2, |
---|
| 4471 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4472 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4473 | IF( IERR .NE. 0 ) RETURN |
---|
| 4474 | IF( NXDEF(1) .GT. 1 ) THEN |
---|
| 4475 | CALL TMONO ( X1, NXDEF, DX, SUBFLG, NSF, 'X1', 2, |
---|
| 4476 | * NBAD, IOU ) |
---|
| 4477 | NDIAG = NDIAG + NBAD |
---|
| 4478 | CALL TSTDX ( X1, NXDEF, NX, DX, SUBFLG, NSF, 'X1', 2, |
---|
| 4479 | * NDIAG, IOU ) |
---|
| 4480 | ELSE |
---|
| 4481 | IF( NX(1) .GT. 1 .AND. DX(1) .EQ. 0.0 ) THEN |
---|
| 4482 | WRITE( IOU,* ) |
---|
| 4483 | * ' **RH3010 error--DX(1)=0 and NXDEF(1)<NX(1)' |
---|
| 4484 | WRITE( IOU,* ) ' X1(I) can not be properly defined' |
---|
| 4485 | WRITE( IOU,* ) ' NXDEF(1),NX(1)= ', NXDEF(1), NX(1) |
---|
| 4486 | NDIAG = NDIAG + 1 |
---|
| 4487 | ENDIF |
---|
| 4488 | DO 26 I=2,NX(1) |
---|
| 4489 | X1(I) = X1(1) + FLOAT( I-1 ) * DX(1) |
---|
| 4490 | 26 CONTINUE |
---|
| 4491 | ENDIF |
---|
| 4492 | C |
---|
| 4493 | CALL PARHD ( X2, NXDEF(2), NFIND, SUBFLG, NSF, 'X2', 2, |
---|
| 4494 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4495 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4496 | IF( IERR .NE. 0 ) RETURN |
---|
| 4497 | IF( NXDEF(2) .GT. 1 ) THEN |
---|
| 4498 | CALL TMONO ( X2, NXDEF(2), DX(2), SUBFLG, NSF, 'X2', 2, |
---|
| 4499 | * NBAD, IOU ) |
---|
| 4500 | NDIAG = NDIAG + NBAD |
---|
| 4501 | CALL TSTDX ( X2, NXDEF(2), NX(2), DX(2), SUBFLG, NSF, 'X2', 2, |
---|
| 4502 | * NDIAG, IOU ) |
---|
| 4503 | ELSE |
---|
| 4504 | IF( NX(2) .GT. 1 .AND. DX(2) .EQ. 0.0 ) THEN |
---|
| 4505 | WRITE( IOU,* ) |
---|
| 4506 | * ' **RH3010 error--DX(2)=0 and NXDEF(2)<NX(2)' |
---|
| 4507 | WRITE( IOU,* ) ' X2(I) can not be properly defined' |
---|
| 4508 | WRITE( IOU,* ) ' NXDEF(2), NX(2)= ', NXDEF(2), NX(2) |
---|
| 4509 | NDIAG = NDIAG + 1 |
---|
| 4510 | ENDIF |
---|
| 4511 | DO 28 I=2,NX(2) |
---|
| 4512 | X2(I) = X2(1) + FLOAT( I-1 ) * DX(2) |
---|
| 4513 | 28 CONTINUE |
---|
| 4514 | ENDIF |
---|
| 4515 | C |
---|
| 4516 | CALL RHSTRN ( XNAME, 3, SUBFLG, NSF, 'XNAME', 5, |
---|
| 4517 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4518 | IF( IERR .NE. 0 ) RETURN |
---|
| 4519 | C |
---|
| 4520 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 4521 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4522 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4523 | IF( IERR .NE. 0 ) RETURN |
---|
| 4524 | NV = INT( DUM + 0.5 ) |
---|
| 4525 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 4526 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4527 | IF( IERR .NE. 0 ) RETURN |
---|
| 4528 | C |
---|
| 4529 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 4530 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4531 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4532 | IF( IERR .NE. 0 ) RETURN |
---|
| 4533 | DO 40 N=1,NV |
---|
| 4534 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 4535 | WRITE(IOU,*) ' **RH3010 error--VSCAL(N)=0, for N=', N |
---|
| 4536 | ENDIF |
---|
| 4537 | 40 CONTINUE |
---|
| 4538 | C |
---|
| 4539 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 4540 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4541 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4542 | IF( IERR .NE. 0 ) RETURN |
---|
| 4543 | C |
---|
| 4544 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 4545 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4546 | IF( IERR .NE. 0 ) RETURN |
---|
| 4547 | C |
---|
| 4548 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 4549 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4550 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4551 | IF( IERR .NE. 0 ) RETURN |
---|
| 4552 | NAUXV = INT( DUM + 0.5 ) |
---|
| 4553 | CALL TIXN ( NAUXV, 0, MAXA, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 4554 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4555 | IF( IERR .NE. 0 ) RETURN |
---|
| 4556 | C |
---|
| 4557 | IF( NAUXV .GT. 0 ) THEN |
---|
| 4558 | CALL PARHD ( ASCAL, NAUXV, NFIND, SUBFLG, NSF, 'ASCAL', 5, |
---|
| 4559 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4560 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4561 | IF( IERR .NE. 0 ) RETURN |
---|
| 4562 | DO 50 NA=1,NAUXV |
---|
| 4563 | IF( ASCAL(NA) .EQ. 0.0 ) THEN |
---|
| 4564 | WRITE(IOU,*) ' **RH3010 error--ASCAL(I)=0, for I=', NA |
---|
| 4565 | ENDIF |
---|
| 4566 | 50 CONTINUE |
---|
| 4567 | C |
---|
| 4568 | CALL PARHD ( AMISS, NAUXV, NFIND, SUBFLG, NSF, 'AMISS', 5, |
---|
| 4569 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4570 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4571 | IF( IERR .NE. 0 ) RETURN |
---|
| 4572 | C |
---|
| 4573 | CALL RHSTRN ( ANAME, NAUXV, SUBFLG, NSF, 'ANAME', 5, |
---|
| 4574 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4575 | IF( IERR .NE. 0 ) RETURN |
---|
| 4576 | ENDIF |
---|
| 4577 | C |
---|
| 4578 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 4579 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4580 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4581 | IF( IERR .NE. 0 ) RETURN |
---|
| 4582 | NSCOML = INT( DUM + 0.5 ) |
---|
| 4583 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 4584 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4585 | IF( IERR .NE. 0 ) RETURN |
---|
| 4586 | C |
---|
| 4587 | IF( NSCOML .GT. 0 ) THEN |
---|
| 4588 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 4589 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4590 | IF( IERR .NE. 0 ) RETURN |
---|
| 4591 | ENDIF |
---|
| 4592 | C |
---|
| 4593 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4594 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4595 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4596 | IF( IERR .NE. 0 ) RETURN |
---|
| 4597 | NNCOML = INT( DUM + 0.5 ) |
---|
| 4598 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4599 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4600 | IF( IERR .NE. 0 ) RETURN |
---|
| 4601 | C |
---|
| 4602 | IF( NNCOML .GT. 0 ) THEN |
---|
| 4603 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 4604 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4605 | IF( IERR .NE. 0 ) RETURN |
---|
| 4606 | ENDIF |
---|
| 4607 | C |
---|
| 4608 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 4609 | WRITE(IOU,*) ' **RH3010 thinks NLHEAD may be in error' |
---|
| 4610 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 4611 | NDIAG = NDIAG + 1 |
---|
| 4612 | ENDIF |
---|
| 4613 | RETURN |
---|
| 4614 | END |
---|
| 4615 | SUBROUTINE RH4010 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4616 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4617 | * DX, NX, NXDEF, X1, X2, X3, XNAME, |
---|
| 4618 | * NV, VSCAL, VMISS, VNAME, |
---|
| 4619 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 4620 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 4621 | * MAXX1, MAXX2, MAXX3, MAXV, MAXA, MAXCOM, CDUM, |
---|
| 4622 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4623 | C |
---|
| 4624 | C Subroutine to read file header for FFI=4010. |
---|
| 4625 | C IERR = 0 = successful read. |
---|
| 4626 | C = <0 = EOF encountered. |
---|
| 4627 | C = >0 = read error. |
---|
| 4628 | C |
---|
| 4629 | C History: |
---|
| 4630 | C 91-12-17 - Replaced RHINT, RHMISS, RHSCAL routines with PARHD |
---|
| 4631 | C and TIXN routines, to `parse' numeric values in the |
---|
| 4632 | C file header records. |
---|
| 4633 | C |
---|
| 4634 | C Required routines: PARHD, RHBGIN, RHSTRN, |
---|
| 4635 | C TIXN, TMONO, TSTDX. |
---|
| 4636 | C |
---|
| 4637 | C |
---|
| 4638 | CHARACTER*(*) ANAME( * ) |
---|
| 4639 | CHARACTER*(*) CDUM |
---|
| 4640 | CHARACTER*(*) CRFMT |
---|
| 4641 | CHARACTER*(*) MNAME |
---|
| 4642 | CHARACTER*(*) NCOM( * ) |
---|
| 4643 | CHARACTER*(*) ONAME |
---|
| 4644 | CHARACTER*(*) ORG |
---|
| 4645 | CHARACTER*(*) SCOM( * ) |
---|
| 4646 | CHARACTER*(*) SNAME |
---|
| 4647 | CHARACTER*6 SUBFLG |
---|
| 4648 | CHARACTER*(*) VNAME( * ) |
---|
| 4649 | CHARACTER*(*) XNAME( * ) |
---|
| 4650 | C |
---|
| 4651 | DIMENSION AMISS( * ), ASCAL( * ), DX( * ), NXDEF( * ), NX( * ) |
---|
| 4652 | DIMENSION VMISS( * ), VSCAL( * ), X1( * ), X2( * ), X3( * ) |
---|
| 4653 | C |
---|
| 4654 | DATA NSF / 6 / |
---|
| 4655 | DATA SUBFLG / 'RH4010' / |
---|
| 4656 | C |
---|
| 4657 | C |
---|
| 4658 | IERR = 0 |
---|
| 4659 | LINE = 0 |
---|
| 4660 | NCIDR = 0 |
---|
| 4661 | NBIDR = 0 |
---|
| 4662 | C |
---|
| 4663 | CALL RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4664 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4665 | * LINE, SUBFLG, NSF, CDUM, CRFMT, |
---|
| 4666 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4667 | IF( IERR .NE. 0 ) RETURN |
---|
| 4668 | C |
---|
| 4669 | CALL PARHD ( DX, 4, NFIND, SUBFLG, NSF, 'DX', 2, |
---|
| 4670 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4671 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4672 | IF( IERR .NE. 0 ) RETURN |
---|
| 4673 | C |
---|
| 4674 | CALL PARHD ( VSCAL, 3, NFIND, SUBFLG, NSF, 'NX', 2, |
---|
| 4675 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4676 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4677 | IF( IERR .NE. 0 ) RETURN |
---|
| 4678 | NX(1) = INT( VSCAL(1) + 0.5 ) |
---|
| 4679 | NX(2) = INT( VSCAL(2) + 0.5 ) |
---|
| 4680 | NX(3) = INT( VSCAL(3) + 0.5 ) |
---|
| 4681 | CALL TIXN ( NX(1), 1, MAXX1, SUBFLG, NSF, 'NX(1)', 5, |
---|
| 4682 | * IUN, IOU, NDIAG, IER1 ) |
---|
| 4683 | CALL TIXN ( NX(2), 1, MAXX2, SUBFLG, NSF, 'NX(2)', 5, |
---|
| 4684 | * IUN, IOU, NDIAG, IER2 ) |
---|
| 4685 | CALL TIXN ( NX(3), 1, MAXX3, SUBFLG, NSF, 'NX(3)', 5, |
---|
| 4686 | * IUN, IOU, NDIAG, IER3 ) |
---|
| 4687 | IF( IER1+IER2+IER3 .NE. 0 ) RETURN |
---|
| 4688 | C |
---|
| 4689 | CALL PARHD ( VSCAL, 3, NFIND, SUBFLG, NSF, 'NXDEF', 5, |
---|
| 4690 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4691 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4692 | IF( IERR .NE. 0 ) RETURN |
---|
| 4693 | NXDEF(1) = INT( VSCAL(1) + 0.5 ) |
---|
| 4694 | NXDEF(2) = INT( VSCAL(2) + 0.5 ) |
---|
| 4695 | NXDEF(3) = INT( VSCAL(3) + 0.5 ) |
---|
| 4696 | MAXX = MAXX1 |
---|
| 4697 | DO 22 N=1,3 |
---|
| 4698 | IF( N .EQ. 2 ) THEN |
---|
| 4699 | MAXX = MAXX2 |
---|
| 4700 | ELSE IF( N .EQ. 3 ) THEN |
---|
| 4701 | MAXX = MAXX3 |
---|
| 4702 | ENDIF |
---|
| 4703 | IF( NXDEF(N) .LT. 1 .OR. NXDEF(N) .GT. NX(N) .OR. |
---|
| 4704 | * (NXDEF(N) .GT. 1 .AND. NXDEF(N) .LT. NX(N)) ) THEN |
---|
| 4705 | WRITE( IOU,* ) |
---|
| 4706 | * ' ***RH4010 error--improper value for NXDEF',N |
---|
| 4707 | WRITE( IOU,* ) ' MAXX,NXDEF,NX=', MAXX, NXDEF(N), NX(N) |
---|
| 4708 | IERR = 2 |
---|
| 4709 | NDIAG = NDIAG + 1 |
---|
| 4710 | RETURN |
---|
| 4711 | ENDIF |
---|
| 4712 | 22 CONTINUE |
---|
| 4713 | C |
---|
| 4714 | CALL PARHD ( X1, NXDEF(1), NFIND, SUBFLG, NSF, 'X1', 2, |
---|
| 4715 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4716 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4717 | IF( IERR .NE. 0 ) RETURN |
---|
| 4718 | IF( NXDEF(1) .GT. 1 ) THEN |
---|
| 4719 | CALL TMONO ( X1, NXDEF(1), DX(1), SUBFLG, NSF, 'X1', 2, |
---|
| 4720 | * NBAD, IOU ) |
---|
| 4721 | NDIAG = NDIAG + NBAD |
---|
| 4722 | CALL TSTDX ( X1, NXDEF(1), NX, DX, SUBFLG, NSF, 'X1', 2, |
---|
| 4723 | * NDIAG, IOU ) |
---|
| 4724 | ELSE |
---|
| 4725 | IF( NX(1) .GT. 1 .AND. DX(1) .EQ. 0.0 ) THEN |
---|
| 4726 | WRITE( IOU,* ) |
---|
| 4727 | * ' **RH4010 error--DX(1)=0 and NXDEF(1)<NX(1)' |
---|
| 4728 | WRITE( IOU,* ) ' X1(I) can not be properly defined' |
---|
| 4729 | WRITE( IOU,* ) ' NXDEF(1), NX(1)= ', NXDEF(1), NX(1) |
---|
| 4730 | NDIAG = NDIAG + 1 |
---|
| 4731 | ENDIF |
---|
| 4732 | DO 26 I=2,NX(1) |
---|
| 4733 | X1(I) = X1(1) + FLOAT( I-1 ) * DX(1) |
---|
| 4734 | 26 CONTINUE |
---|
| 4735 | ENDIF |
---|
| 4736 | C |
---|
| 4737 | CALL PARHD ( X2, NXDEF(2), NFIND, SUBFLG, NSF, 'X2', 2, |
---|
| 4738 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4739 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4740 | IF( IERR .NE. 0 ) RETURN |
---|
| 4741 | IF( NXDEF(2) .GT. 1 ) THEN |
---|
| 4742 | CALL TMONO ( X2, NXDEF(2), DX(2), SUBFLG, NSF, 'X2', 2, |
---|
| 4743 | * NBAD, IOU ) |
---|
| 4744 | NDIAG = NDIAG + NBAD |
---|
| 4745 | CALL TSTDX ( X2, NXDEF(2), NX(2), DX(2), SUBFLG, NSF, 'X2', 2, |
---|
| 4746 | * NDIAG, IOU ) |
---|
| 4747 | ELSE |
---|
| 4748 | IF( NX(2) .GT. 1 .AND. DX(2) .EQ. 0.0 ) THEN |
---|
| 4749 | WRITE( IOU,* ) |
---|
| 4750 | * ' **RH4010 error--DX(2)=0 and NXDEF(2)<NX(2)' |
---|
| 4751 | WRITE( IOU,* ) ' X2(I) can not be properly defined' |
---|
| 4752 | WRITE( IOU,* ) ' NXDEF(2), NX(2)= ', NXDEF(2), NX(2) |
---|
| 4753 | NDIAG = NDIAG + 1 |
---|
| 4754 | ENDIF |
---|
| 4755 | DO 28 I=2,NX(2) |
---|
| 4756 | X2(I) = X2(1) + FLOAT( I-1 ) * DX(2) |
---|
| 4757 | 28 CONTINUE |
---|
| 4758 | ENDIF |
---|
| 4759 | C |
---|
| 4760 | CALL PARHD ( X3, NXDEF(3), NFIND, SUBFLG, NSF, 'X3', 2, |
---|
| 4761 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4762 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4763 | IF( IERR .NE. 0 ) RETURN |
---|
| 4764 | IF( NXDEF(3) .GT. 1 ) THEN |
---|
| 4765 | CALL TMONO ( X3, NXDEF(3), DX(3), SUBFLG, NSF, 'X3', 2, |
---|
| 4766 | * NBAD, IOU ) |
---|
| 4767 | NDIAG = NDIAG + NBAD |
---|
| 4768 | CALL TSTDX ( X3, NXDEF(3), NX(3), DX(3), SUBFLG, NSF, 'X3', 2, |
---|
| 4769 | * NDIAG, IOU ) |
---|
| 4770 | ELSE |
---|
| 4771 | IF( NX(3) .GT. 1 .AND. DX(3) .EQ. 0.0 ) THEN |
---|
| 4772 | WRITE( IOU,* ) |
---|
| 4773 | * ' **RH4010 error--DX(3)=0 and NXDEF(3)<NX(3)' |
---|
| 4774 | WRITE( IOU,* ) ' X3(I) can not be properly defined' |
---|
| 4775 | WRITE( IOU,* ) ' NXDEF(3), NX(3)= ', NXDEF(3), NX(3) |
---|
| 4776 | NDIAG = NDIAG + 1 |
---|
| 4777 | ENDIF |
---|
| 4778 | DO 30 I=2,NX(3) |
---|
| 4779 | X3(I) = X3(1) + FLOAT( I-1 ) * DX(3) |
---|
| 4780 | 30 CONTINUE |
---|
| 4781 | ENDIF |
---|
| 4782 | C |
---|
| 4783 | CALL RHSTRN ( XNAME, 4, SUBFLG, NSF, 'XNAME', 5, |
---|
| 4784 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4785 | IF( IERR .NE. 0 ) RETURN |
---|
| 4786 | C |
---|
| 4787 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NV', 2, |
---|
| 4788 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4789 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4790 | IF( IERR .NE. 0 ) RETURN |
---|
| 4791 | NV = INT( DUM + 0.5 ) |
---|
| 4792 | CALL TIXN ( NV, 1, MAXV, SUBFLG, NSF, 'NV', 2, |
---|
| 4793 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4794 | IF( IERR .NE. 0 ) RETURN |
---|
| 4795 | C |
---|
| 4796 | CALL PARHD ( VSCAL, NV, NFIND, SUBFLG, NSF, 'VSCAL', 5, |
---|
| 4797 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4798 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4799 | IF( IERR .NE. 0 ) RETURN |
---|
| 4800 | DO 40 N=1,NV |
---|
| 4801 | IF( VSCAL(N) .EQ. 0.0 ) THEN |
---|
| 4802 | WRITE(IOU,*) ' **RH4010 error--VSCAL(N)=0, for N=', N |
---|
| 4803 | ENDIF |
---|
| 4804 | 40 CONTINUE |
---|
| 4805 | C |
---|
| 4806 | CALL PARHD ( VMISS, NV, NFIND, SUBFLG, NSF, 'VMISS', 5, |
---|
| 4807 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4808 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4809 | IF( IERR .NE. 0 ) RETURN |
---|
| 4810 | C |
---|
| 4811 | CALL RHSTRN ( VNAME, NV, SUBFLG, NSF, 'VNAME', 5, |
---|
| 4812 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4813 | IF( IERR .NE. 0 ) RETURN |
---|
| 4814 | C |
---|
| 4815 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 4816 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4817 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4818 | IF( IERR .NE. 0 ) RETURN |
---|
| 4819 | NAUXV = INT( DUM + 0.5 ) |
---|
| 4820 | CALL TIXN ( NAUXV, 0, MAXA, SUBFLG, NSF, 'NAUXV', 5, |
---|
| 4821 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4822 | IF( IERR .NE. 0 ) RETURN |
---|
| 4823 | C |
---|
| 4824 | IF( NAUXV .GT. 0 ) THEN |
---|
| 4825 | CALL PARHD ( ASCAL, NAUXV, NFIND, SUBFLG, NSF, 'ASCAL', 5, |
---|
| 4826 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4827 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4828 | IF( IERR .NE. 0 ) RETURN |
---|
| 4829 | DO 50 NA=1,NAUXV |
---|
| 4830 | IF( ASCAL(NA) .EQ. 0.0 ) THEN |
---|
| 4831 | WRITE(IOU,*) ' **RH4010 error--ASCAL(I)=0, for I=', NA |
---|
| 4832 | ENDIF |
---|
| 4833 | 50 CONTINUE |
---|
| 4834 | C |
---|
| 4835 | CALL PARHD ( AMISS, NAUXV, NFIND, SUBFLG, NSF, 'AMISS', 5, |
---|
| 4836 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4837 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4838 | IF( IERR .NE. 0 ) RETURN |
---|
| 4839 | C |
---|
| 4840 | CALL RHSTRN ( ANAME, NAUXV, SUBFLG, NSF, 'ANAME', 5, |
---|
| 4841 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4842 | IF( IERR .NE. 0 ) RETURN |
---|
| 4843 | ENDIF |
---|
| 4844 | C |
---|
| 4845 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 4846 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4847 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4848 | IF( IERR .NE. 0 ) RETURN |
---|
| 4849 | NSCOML = INT( DUM + 0.5 ) |
---|
| 4850 | CALL TIXN ( NSCOML, 0, MAXCOM, SUBFLG, NSF, 'NSCOML', 6, |
---|
| 4851 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4852 | IF( IERR .NE. 0 ) RETURN |
---|
| 4853 | C |
---|
| 4854 | IF( NSCOML .GT. 0 ) THEN |
---|
| 4855 | CALL RHSTRN ( SCOM, NSCOML, SUBFLG, NSF, 'SCOM', 4, |
---|
| 4856 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4857 | IF( IERR .NE. 0 ) RETURN |
---|
| 4858 | ENDIF |
---|
| 4859 | C |
---|
| 4860 | CALL PARHD ( DUM, 1, NFIND, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4861 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4862 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4863 | IF( IERR .NE. 0 ) RETURN |
---|
| 4864 | NNCOML = INT( DUM + 0.5 ) |
---|
| 4865 | CALL TIXN ( NNCOML, 0, MAXCOM, SUBFLG, NSF, 'NNCOML', 6, |
---|
| 4866 | * IUN, IOU, NDIAG, IERR ) |
---|
| 4867 | IF( IERR .NE. 0 ) RETURN |
---|
| 4868 | C |
---|
| 4869 | IF( NNCOML .GT. 0 ) THEN |
---|
| 4870 | CALL RHSTRN ( NCOM, NNCOML, SUBFLG, NSF, 'NCOM', 4, |
---|
| 4871 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4872 | IF( IERR .NE. 0 ) RETURN |
---|
| 4873 | ENDIF |
---|
| 4874 | C |
---|
| 4875 | IF( LINE .NE. NLHEAD ) THEN |
---|
| 4876 | WRITE(IOU,*) ' **RH4010 thinks NLHEAD may be in error' |
---|
| 4877 | WRITE(IOU,*) ' NLHEAD,LINE=', NLHEAD, LINE |
---|
| 4878 | NDIAG = NDIAG + 1 |
---|
| 4879 | ENDIF |
---|
| 4880 | RETURN |
---|
| 4881 | END |
---|
| 4882 | SUBROUTINE RHBGIN ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4883 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4884 | * LINE, SUBFLG, NSF, CDUM, |
---|
| 4885 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4886 | C |
---|
| 4887 | C Subroutine to read and return the first seven lines from file headers. |
---|
| 4888 | C |
---|
| 4889 | C History: |
---|
| 4890 | C 91-12-17 - Modified to use PARHD to read numeric values, and |
---|
| 4891 | C TIXN to test and diagnose them. |
---|
| 4892 | C |
---|
| 4893 | C |
---|
| 4894 | C Required routines: PARHD, RHSTRN, TIXN. |
---|
| 4895 | C |
---|
| 4896 | CHARACTER*(*) CDUM |
---|
| 4897 | CHARACTER*(*) CRFMT |
---|
| 4898 | CHARACTER*(*) MNAME |
---|
| 4899 | CHARACTER*(*) ONAME |
---|
| 4900 | CHARACTER*(*) ORG |
---|
| 4901 | CHARACTER*(*) SNAME |
---|
| 4902 | CHARACTER*(*) SUBFLG |
---|
| 4903 | C |
---|
| 4904 | DIMENSION DUM( 10 ) |
---|
| 4905 | C |
---|
| 4906 | NCIDR = 0 |
---|
| 4907 | NBIDR = 0 |
---|
| 4908 | CALL PARHD ( DUM, 2, NFIND, 'RHBGIN', 6, 'NLHEAD,FFI', 10, |
---|
| 4909 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4910 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4911 | IF( IERR .NE. 0 ) RETURN |
---|
| 4912 | NLHEAD = INT( DUM(1) + 0.5 ) |
---|
| 4913 | IFFI = INT( DUM(2) + 0.5 ) |
---|
| 4914 | C |
---|
| 4915 | CALL RHSTRN ( ONAME, 1, 'RHBGIN', 6, 'ONAME', 5, |
---|
| 4916 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4917 | IF( IERR .NE. 0 ) RETURN |
---|
| 4918 | C |
---|
| 4919 | CALL RHSTRN ( ORG, 1, 'RHBGIN', 6, 'ORG', 3, |
---|
| 4920 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4921 | IF( IERR .NE. 0 ) RETURN |
---|
| 4922 | C |
---|
| 4923 | CALL RHSTRN ( SNAME, 1, 'RHBGIN', 6, 'SNAME', 5, |
---|
| 4924 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4925 | IF( IERR .NE. 0 ) RETURN |
---|
| 4926 | C |
---|
| 4927 | CALL RHSTRN ( MNAME, 1, 'RHBGIN', 6, 'MNAME', 5, |
---|
| 4928 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4929 | IF( IERR .NE. 0 ) RETURN |
---|
| 4930 | C |
---|
| 4931 | CALL PARHD ( DUM, 2, NFIND, 'RHBGIN', 6, 'IVOL,NVOL', 9, |
---|
| 4932 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4933 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4934 | IF( IERR .NE. 0 ) RETURN |
---|
| 4935 | IVOL = INT( DUM(1) + 0.5 ) |
---|
| 4936 | NVOL = INT( DUM(2) + 0.5 ) |
---|
| 4937 | CALL TIXN ( NVOL, 1, 9, 'RHBGIN', 6, 'NVOL', 4, |
---|
| 4938 | * IUN, IOU, NDIAG, IER1 ) |
---|
| 4939 | CALL TIXN ( IVOL, 1, NVOL, 'RHBGIN', 6, 'IVOL', 4, |
---|
| 4940 | * IUN, IOU, NDIAG, IER2 ) |
---|
| 4941 | IF( IER1+IER2 .NE. 0 ) RETURN |
---|
| 4942 | C |
---|
| 4943 | CALL PARHD ( DUM, 6, NFIND, 'RHBGIN', 6, 'DATE,RDATE', 10, |
---|
| 4944 | * LINE, NREAD, CDUM, NCIDR, NBIDR, |
---|
| 4945 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 4946 | IF( IERR .NE. 0 ) RETURN |
---|
| 4947 | IYR = INT( DUM(1) + 0.5 ) |
---|
| 4948 | IMO = INT( DUM(2) + 0.5 ) |
---|
| 4949 | IDY = INT( DUM(3) + 0.5 ) |
---|
| 4950 | IRYR = INT( DUM(4) + 0.5 ) |
---|
| 4951 | IRMO = INT( DUM(5) + 0.5 ) |
---|
| 4952 | IRDY = INT( DUM(6) + 0.5 ) |
---|
| 4953 | IDATE = IYR * 10000 + IMO * 100 + IDY |
---|
| 4954 | IRDATE = IRYR * 10000 + IRMO * 100 + IRDY |
---|
| 4955 | IF( IDATE .GT. IRDATE .OR. IDATE .LT. 19000000 ) THEN |
---|
| 4956 | WRITE( IOU,* ) ' **RHBGIN error--improper DATE, RDATE' |
---|
| 4957 | WRITE( IOU,* ) ' RHBGIN called by ',SUBFLG(1:NSF) |
---|
| 4958 | IF( IDATE .GT. IRDATE ) WRITE(IOU,*) ' RDATE .LT. DATE' |
---|
| 4959 | WRITE( IOU,* ) ' IYR, IMO, IDY=', IYR, IMO, IDY |
---|
| 4960 | WRITE( IOU,* ) ' IRYR,IRMO,IRDY=', IRYR, IRMO, IRDY |
---|
| 4961 | NDIAG = NDIAG + 1 |
---|
| 4962 | ENDIF |
---|
| 4963 | RETURN |
---|
| 4964 | END |
---|
| 4965 | SUBROUTINE RHEAD ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 4966 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 4967 | * DX, NX, NXDEF, LENX, XNAME, X1, X2, X3, |
---|
| 4968 | * NV, NVPM, VSCAL, VMISS, VNAME, |
---|
| 4969 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 4970 | * NAUXC, LENA, CAMISS, |
---|
| 4971 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 4972 | * MAXX1, MAXX2, MAXX3, |
---|
| 4973 | * MAXV, MAXA, MAXCA, MAXCOM, MAXCPL, CDUM, |
---|
| 4974 | * MNAME0, CRFMT, IUN, IOU, ISUBV, NDIAG, IERR, |
---|
| 4975 | * DBHEAD ) |
---|
| 4976 | C History: |
---|
| 4977 | C 96-02-29 (JDW) |
---|
| 4978 | C Modified to skip over database header if DBHEAD = .TRUE. |
---|
| 4979 | C |
---|
| 4980 | C Subroutine to drive file header reading routines. |
---|
| 4981 | C ISUBV is defined in this routine and used in subroutine RDATA |
---|
| 4982 | C to determine which data reading routine to call. |
---|
| 4983 | C |
---|
| 4984 | C Required routines: LASTNB, |
---|
| 4985 | C RH1001, RH1010, RH1020, |
---|
| 4986 | C RH2010, RH2110, RH2160, RH2310, |
---|
| 4987 | C RH3010, RH4010. |
---|
| 4988 | C |
---|
| 4989 | CHARACTER*(*) ANAME( * ) |
---|
| 4990 | CHARACTER*(*) CAMISS( * ) |
---|
| 4991 | CHARACTER*(*) CDUM |
---|
| 4992 | CHARACTER*(*) CRFMT |
---|
| 4993 | CHARACTER*(*) MNAME |
---|
| 4994 | CHARACTER*(*) MNAME0 |
---|
| 4995 | CHARACTER*(*) NCOM( * ) |
---|
| 4996 | CHARACTER*(*) ONAME |
---|
| 4997 | CHARACTER*(*) ORG |
---|
| 4998 | CHARACTER*(*) SCOM( * ) |
---|
| 4999 | CHARACTER*(*) SNAME |
---|
| 5000 | CHARACTER*(*) VNAME( * ) |
---|
| 5001 | CHARACTER*(*) XNAME( * ) |
---|
| 5002 | C |
---|
| 5003 | DIMENSION DX( * ), NX( * ), NXDEF( * ) |
---|
| 5004 | DIMENSION X1( * ), X2( * ), X3( * ) |
---|
| 5005 | DIMENSION AMISS( * ), ASCAL( * ), LENA( * ) |
---|
| 5006 | DIMENSION VMISS( * ), VSCAL( * ), LENX( * ) |
---|
| 5007 | C |
---|
| 5008 | LOGICAL DBHEAD |
---|
| 5009 | C |
---|
| 5010 | C Initialize some variables that may otherwise cause problems |
---|
| 5011 | C in the kluges at the end of this routine. |
---|
| 5012 | C |
---|
| 5013 | NAUXV = 0 |
---|
| 5014 | NAUXC = 0 |
---|
| 5015 | C |
---|
| 5016 | C Obtain FFI. |
---|
| 5017 | C |
---|
| 5018 | IF (DBHEAD) READ (IUN,*) |
---|
| 5019 | READ( IUN,*,IOSTAT=IERR ) NLHEAD, JFFI |
---|
| 5020 | IF( IERR .NE. 0 ) THEN |
---|
| 5021 | WRITE( IOU,* ) ' ***RHEAD error reading FFI' |
---|
| 5022 | NDIAG = NDIAG + 1 |
---|
| 5023 | RETURN |
---|
| 5024 | ENDIF |
---|
| 5025 | REWIND IUN |
---|
| 5026 | IF (DBHEAD) READ (IUN,*) |
---|
| 5027 | IF( JFFI .EQ. 1001 ) THEN |
---|
| 5028 | ISUBV = 1 |
---|
| 5029 | CALL RH1001 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5030 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5031 | * DX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 5032 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5033 | * MAXV, MAXCOM, CDUM, |
---|
| 5034 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5035 | ELSE IF ( JFFI .EQ. 1010 ) THEN |
---|
| 5036 | ISUBV = 2 |
---|
| 5037 | CALL RH1010 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5038 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5039 | * DX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 5040 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 5041 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5042 | * MAXV, MAXA, MAXCOM, CDUM, |
---|
| 5043 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5044 | ELSE IF ( JFFI .EQ. 1020 ) THEN |
---|
| 5045 | ISUBV = 3 |
---|
| 5046 | CALL RH1020 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5047 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5048 | * DX, NVPM, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 5049 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 5050 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5051 | * MAXX1, MAXV, MAXA, MAXCOM, CDUM, |
---|
| 5052 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5053 | ELSE IF ( JFFI .EQ. 2010 ) THEN |
---|
| 5054 | ISUBV = 4 |
---|
| 5055 | CALL RH2010 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5056 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5057 | * DX, NX, NXDEF, X1, XNAME, |
---|
| 5058 | * NV, VSCAL, VMISS, VNAME, |
---|
| 5059 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 5060 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5061 | * MAXX1, MAXV, MAXA, MAXCOM, CDUM, |
---|
| 5062 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5063 | ELSE IF ( JFFI .EQ. 2110 ) THEN |
---|
| 5064 | ISUBV = 5 |
---|
| 5065 | CALL RH2110 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5066 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5067 | * DX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 5068 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 5069 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5070 | * MAXV, MAXA, MAXCOM, CDUM, |
---|
| 5071 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5072 | ELSE IF ( JFFI .EQ. 2160 ) THEN |
---|
| 5073 | ISUBV = 6 |
---|
| 5074 | CALL RH2160 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5075 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5076 | * DX, LENX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 5077 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 5078 | * NAUXC, LENA, CAMISS, X1, |
---|
| 5079 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5080 | * MAXV, MAXA, MAXCA, MAXCOM, MAXCPL, CDUM, |
---|
| 5081 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5082 | ELSE IF ( JFFI .EQ. 2310 ) THEN |
---|
| 5083 | ISUBV = 7 |
---|
| 5084 | CALL RH2310 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5085 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5086 | * DX, XNAME, NV, VSCAL, VMISS, VNAME, |
---|
| 5087 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 5088 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5089 | * MAXV, MAXA, MAXCOM, CDUM, |
---|
| 5090 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5091 | ELSE IF ( JFFI .EQ. 3010 ) THEN |
---|
| 5092 | ISUBV = 8 |
---|
| 5093 | CALL RH3010 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5094 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5095 | * DX, NX, NXDEF, X1, X2, XNAME, |
---|
| 5096 | * NV, VSCAL, VMISS, VNAME, |
---|
| 5097 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 5098 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5099 | * MAXX1, MAXX2, MAXV, MAXA, MAXCOM, CDUM, |
---|
| 5100 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5101 | ELSE IF ( JFFI .EQ. 4010 ) THEN |
---|
| 5102 | ISUBV = 9 |
---|
| 5103 | CALL RH4010 ( NLHEAD, IFFI, ONAME, ORG, SNAME, MNAME, |
---|
| 5104 | * IVOL, NVOL, IYR, IMO, IDY, IRYR, IRMO, IRDY, |
---|
| 5105 | * DX, NX, NXDEF, X1, X2, X3, XNAME, |
---|
| 5106 | * NV, VSCAL, VMISS, VNAME, |
---|
| 5107 | * NAUXV, ASCAL, AMISS, ANAME, |
---|
| 5108 | * NSCOML, SCOM, NNCOML, NCOM, |
---|
| 5109 | * MAXX1, MAXX2, MAXX3, MAXV, MAXA, MAXCOM, CDUM, |
---|
| 5110 | * CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5111 | ELSE |
---|
| 5112 | WRITE( IOU,* ) ' ***RHEAD error--unknown value for FFI=', JFFI |
---|
| 5113 | NDIAG = NDIAG + 1 |
---|
| 5114 | IERR = 2 |
---|
| 5115 | RETURN |
---|
| 5116 | ENDIF |
---|
| 5117 | IF( IERR .NE. 0 ) RETURN |
---|
| 5118 | C |
---|
| 5119 | C Test for proper mission name. |
---|
| 5120 | C |
---|
| 5121 | c CALL LASTNB ( MNAME0, LEN(MNAME0), L0 ) |
---|
| 5122 | c IFOUND = INDEX( MNAME, MNAME0(1:L0) ) |
---|
| 5123 | c IF( IFOUND .LT. 1 ) THEN |
---|
| 5124 | c CALL LASTNB ( MNAME, LEN(MNAME), L ) |
---|
| 5125 | c WRITE( IOU,* ) ' **RHEAD error--improper mission name' |
---|
| 5126 | c WRITE( IOU,* ) ' MNAME0=',MNAME0(1:L0) |
---|
| 5127 | c WRITE( IOU,* ) ' MNAME =',MNAME(1:L) |
---|
| 5128 | c NDIAG = NDIAG + 1 |
---|
| 5129 | c ELSE |
---|
| 5130 | c CALL FRSTNB ( MNAME, LEN(MNAME), L1 ) |
---|
| 5131 | c CALL LASTNB ( MNAME, LEN(MNAME), L2 ) |
---|
| 5132 | c IF( L1 .NE. IFOUND ) THEN |
---|
| 5133 | c WRITE( IOU,* ) ' **RHEAD error--improper mission name' |
---|
| 5134 | c WRITE( IOU,* ) ' MNAME0=',MNAME0(1:L0) |
---|
| 5135 | c WRITE( IOU,* ) ' MNAME =',MNAME(1:L2) |
---|
| 5136 | c WRITE( IOU,* ) |
---|
| 5137 | c * ' MNAME0 must be first non-blank character' |
---|
| 5138 | c NDIAG = NDIAG + 1 |
---|
| 5139 | c ENDIF |
---|
| 5140 | c ENDIF |
---|
| 5141 | C |
---|
| 5142 | C This is kluged test for improper missing values. |
---|
| 5143 | C It would be better to test each data value to ensure it is .LE. the |
---|
| 5144 | C appropriate missing value, but this kluge is less time consuming. |
---|
| 5145 | C |
---|
| 5146 | DO 70 N=1,NV |
---|
| 5147 | IF( VMISS(N) .LT. 0.0 ) THEN |
---|
| 5148 | WRITE( IOU,* ) |
---|
| 5149 | * ' **RHEAD error--improper VMISS value' |
---|
| 5150 | WRITE( IOU,* ) |
---|
| 5151 | * ' N, VMISS(N) = ', N, VMISS(N) |
---|
| 5152 | WRITE( IOU,* ) |
---|
| 5153 | * ' VMISS should be larger than "good" data values' |
---|
| 5154 | NDIAG = NDIAG + 1 |
---|
| 5155 | ENDIF |
---|
| 5156 | 70 CONTINUE |
---|
| 5157 | IF( NAUXV-NAUXC .GT. 0 ) THEN |
---|
| 5158 | DO 72 IA=1,NAUXV-NAUXC |
---|
| 5159 | IF( AMISS(IA) .LT. 0.0 ) THEN |
---|
| 5160 | WRITE( IOU,* ) |
---|
| 5161 | * ' **RHEAD error--improper AMISS value' |
---|
| 5162 | WRITE( IOU,* ) |
---|
| 5163 | * ' IA, AMISS(IA) = ', IA, AMISS(IA) |
---|
| 5164 | WRITE( IOU,* ) |
---|
| 5165 | * ' AMISS should be larger than "good" data values' |
---|
| 5166 | NDIAG = NDIAG + 1 |
---|
| 5167 | ENDIF |
---|
| 5168 | 72 CONTINUE |
---|
| 5169 | ENDIF |
---|
| 5170 | RETURN |
---|
| 5171 | END |
---|
| 5172 | SUBROUTINE RHSTRN ( VNAME, NV, SUBFLG, NSF, VALFLG, NVF, |
---|
| 5173 | * LINE, CRFMT, IUN, IOU, NDIAG, IERR ) |
---|
| 5174 | C |
---|
| 5175 | C Subroutine to read character string records. |
---|
| 5176 | C |
---|
| 5177 | C |
---|
| 5178 | CHARACTER*(*) CRFMT |
---|
| 5179 | CHARACTER*(*) SUBFLG |
---|
| 5180 | CHARACTER*(*) VALFLG |
---|
| 5181 | CHARACTER*(*) VNAME( * ) |
---|
| 5182 | C |
---|
| 5183 | C |
---|
| 5184 | DO 50 N=1,NV |
---|
| 5185 | READ( IUN,FMT=CRFMT,IOSTAT=IERR ) VNAME(N) |
---|
| 5186 | IF( IERR .NE. 0 ) THEN |
---|
| 5187 | WRITE( IOU,* ) |
---|
| 5188 | * ' ***RHSTRN error reading ',VALFLG(1:NVF),' at line ', LINE+1 |
---|
| 5189 | WRITE( IOU,* ) ' RHSTRN called by ',SUBFLG(1:NSF) |
---|
| 5190 | NDIAG = NDIAG + 1 |
---|
| 5191 | RETURN |
---|
| 5192 | ENDIF |
---|
| 5193 | LINE = LINE + 1 |
---|
| 5194 | 50 CONTINUE |
---|
| 5195 | RETURN |
---|
| 5196 | END |
---|
| 5197 | SUBROUTINE TCIVM ( CX, LENX, CVAL, VALFLG, NVF, NIVM, |
---|
| 5198 | * NDIAG, IOU, IERR ) |
---|
| 5199 | C |
---|
| 5200 | C Subroutine to test character independent variable marks to see if |
---|
| 5201 | C they are monotonic. |
---|
| 5202 | C |
---|
| 5203 | C Required routines: L3CVAL, TMONC. |
---|
| 5204 | C |
---|
| 5205 | CHARACTER*(*) CVAL( * ) |
---|
| 5206 | CHARACTER*(*) CX |
---|
| 5207 | CHARACTER*5 SUBFLG |
---|
| 5208 | CHARACTER*(*) VALFLG |
---|
| 5209 | C |
---|
| 5210 | DATA NSF / 5 / |
---|
| 5211 | DATA SUBFLG / 'TCIVM' / |
---|
| 5212 | C |
---|
| 5213 | IF( IERR .EQ. 0 ) THEN |
---|
| 5214 | NIVM = NIVM + 1 |
---|
| 5215 | CALL L3CVAL ( CX, LENX, NIVM, CVAL ) |
---|
| 5216 | CALL TMONC ( CVAL, LENX, NIVM, SUBFLG, NSF, VALFLG, NVF, |
---|
| 5217 | * NBAD, IOU ) |
---|
| 5218 | NDIAG = NDIAG + NBAD |
---|
| 5219 | ENDIF |
---|
| 5220 | RETURN |
---|
| 5221 | END |
---|
| 5222 | SUBROUTINE TIXN ( N, NMIN, NMAX, SUBFLG, NSF, VALFLG, NVF, |
---|
| 5223 | * IUN, IOU, NDIAG, IERR ) |
---|
| 5224 | C |
---|
| 5225 | C Subroutine to test range of integer value and print diagnostics. |
---|
| 5226 | C |
---|
| 5227 | CHARACTER*(*) SUBFLG |
---|
| 5228 | CHARACTER*(*) VALFLG |
---|
| 5229 | C |
---|
| 5230 | IERR = 0 |
---|
| 5231 | IF( N .LT. NMIN .OR. N .GT. NMAX ) THEN |
---|
| 5232 | WRITE(IOU,*) |
---|
| 5233 | * ' ***TIXN error--improper value for ',VALFLG(1:NVF) |
---|
| 5234 | WRITE(IOU,*) ' TIXN called by ',SUBFLG(1:NSF) |
---|
| 5235 | WRITE(IOU,*) |
---|
| 5236 | * ' ',VALFLG(1:NVF),'MIN,',VALFLG(1:NVF),'MAX=', |
---|
| 5237 | * NMIN, NMAX |
---|
| 5238 | WRITE(IOU,*) ' ',VALFLG(1:NVF),'=', N |
---|
| 5239 | IERR = 2 |
---|
| 5240 | NDIAG = NDIAG + 1 |
---|
| 5241 | RETURN |
---|
| 5242 | ENDIF |
---|
| 5243 | RETURN |
---|
| 5244 | END |
---|
| 5245 | SUBROUTINE TMON3 ( X, N, DX, SUBFLG, NSF, VALFLG, NVF, NBAD, IOU ) |
---|
| 5246 | C |
---|
| 5247 | C Subroutine to test vector X, maximum length of three, to see if |
---|
| 5248 | C it is monotonically increasing or decreasing. |
---|
| 5249 | C |
---|
| 5250 | C Required routines: None. |
---|
| 5251 | C |
---|
| 5252 | C History: |
---|
| 5253 | C 940803 (SEG) - Added loop to test each X. |
---|
| 5254 | C |
---|
| 5255 | C |
---|
| 5256 | CHARACTER*(*) SUBFLG |
---|
| 5257 | CHARACTER*(*) VALFLG |
---|
| 5258 | C |
---|
| 5259 | DIMENSION X( * ) |
---|
| 5260 | C |
---|
| 5261 | NBAD = 0 |
---|
| 5262 | IF( N .GT. 2 ) THEN |
---|
| 5263 | IF( DX .EQ. 0.0 ) THEN |
---|
| 5264 | DD = X(3) - X(1) |
---|
| 5265 | ELSE |
---|
| 5266 | DD = DX |
---|
| 5267 | ENDIF |
---|
| 5268 | J = 3 |
---|
| 5269 | ELSE IF( N .EQ. 2 ) THEN |
---|
| 5270 | IF( DX .NE. 0.0 ) THEN |
---|
| 5271 | DD = DX |
---|
| 5272 | J = 2 |
---|
| 5273 | ELSE |
---|
| 5274 | RETURN |
---|
| 5275 | ENDIF |
---|
| 5276 | ELSE |
---|
| 5277 | RETURN |
---|
| 5278 | ENDIF |
---|
| 5279 | DO 20 I=2,J |
---|
| 5280 | IF( SIGN(1.0,DD)*(X(I)-X(I-1)) .LE. 0.0 ) THEN |
---|
| 5281 | WRITE( IOU,* ) |
---|
| 5282 | * ' **TMON3 error--',VALFLG(1:NVF),' not monotonic' |
---|
| 5283 | WRITE( IOU,* ) ' TMON3 called by ',SUBFLG(1:NSF) |
---|
| 5284 | WRITE( IOU,* ) ' ',VALFLG(1:NVF),'(I-1)=', X(I-1) |
---|
| 5285 | WRITE( IOU,* ) ' ',VALFLG(1:NVF),'(I) =', X(I) |
---|
| 5286 | NBAD = NBAD + 1 |
---|
| 5287 | ENDIF |
---|
| 5288 | 20 CONTINUE |
---|
| 5289 | RETURN |
---|
| 5290 | END |
---|
| 5291 | SUBROUTINE TMONC ( X, LX, N, SUBFLG, NSF, VALFLG, NVF, |
---|
| 5292 | * NBAD, IOU ) |
---|
| 5293 | C |
---|
| 5294 | C Subroutine to test vector X, maximum length of three, to see if |
---|
| 5295 | C it is monotonically increasing or decreasing. |
---|
| 5296 | C |
---|
| 5297 | C Required routines: None. |
---|
| 5298 | C |
---|
| 5299 | CHARACTER*(*) SUBFLG |
---|
| 5300 | CHARACTER*(*) VALFLG |
---|
| 5301 | CHARACTER*(*) X( * ) |
---|
| 5302 | C |
---|
| 5303 | NBAD = 0 |
---|
| 5304 | IF( N .LT. 3 ) RETURN |
---|
| 5305 | IF( X(2)(1:LX) .GT. X(1)(1:LX) .AND. |
---|
| 5306 | * X(3)(1:LX) .GT. X(2)(1:LX) ) RETURN |
---|
| 5307 | IF( X(2)(1:LX) .LT. X(1)(1:LX) .AND. |
---|
| 5308 | * X(3)(1:LX) .LT. X(2)(1:LX) ) RETURN |
---|
| 5309 | WRITE( IOU,* ) |
---|
| 5310 | * ' **TMONC error--',VALFLG(1:NVF),' not monotonic' |
---|
| 5311 | WRITE( IOU,* ) ' TMONC called by ',SUBFLG(1:NSF) |
---|
| 5312 | WRITE( IOU,* ) ' ',VALFLG(1:NVF),'(I-2)= ',X(1)(1:LX) |
---|
| 5313 | WRITE( IOU,* ) ' ',VALFLG(1:NVF),'(I-1)= ',X(2)(1:LX) |
---|
| 5314 | WRITE( IOU,* ) ' ',VALFLG(1:NVF),'(I) = ',X(3)(1:LX) |
---|
| 5315 | NBAD = NBAD + 1 |
---|
| 5316 | RETURN |
---|
| 5317 | END |
---|
| 5318 | SUBROUTINE TMONO ( X, N, DX, SUBFLG, NSF, VALFLG, NVF, NBAD, IOU ) |
---|
| 5319 | C |
---|
| 5320 | C Subroutine to test vector X to see if it is monotonically |
---|
| 5321 | C increasing or decreasing. |
---|
| 5322 | C |
---|
| 5323 | C Required routines: None. |
---|
| 5324 | C |
---|
| 5325 | CHARACTER*(*) SUBFLG |
---|
| 5326 | CHARACTER*(*) VALFLG |
---|
| 5327 | C |
---|
| 5328 | DIMENSION X( * ) |
---|
| 5329 | C |
---|
| 5330 | NBAD = 0 |
---|
| 5331 | IF( N .LT. 2 ) RETURN |
---|
| 5332 | IF( DX .EQ. 0.0 ) THEN |
---|
| 5333 | DD = X(N) - X(1) |
---|
| 5334 | ELSE |
---|
| 5335 | DD = DX |
---|
| 5336 | ENDIF |
---|
| 5337 | DO 20 I=2,N |
---|
| 5338 | IF( SIGN(1.0,DD)*(X(I)-X(I-1)) .LE. 0.0 ) THEN |
---|
| 5339 | WRITE( IOU,* ) |
---|
| 5340 | * ' **TMONO error--',VALFLG(1:NVF),' not monotonic' |
---|
| 5341 | WRITE( IOU,* ) ' TMONO called by ',SUBFLG(1:NSF) |
---|
| 5342 | WRITE( IOU,* ) ' ',VALFLG(1:NVF),'(I-1)=', X(I-1) |
---|
| 5343 | WRITE( IOU,* ) ' ',VALFLG(1:NVF),'(I) =', X(I) |
---|
| 5344 | NBAD = NBAD + 1 |
---|
| 5345 | ENDIF |
---|
| 5346 | 20 CONTINUE |
---|
| 5347 | RETURN |
---|
| 5348 | END |
---|
| 5349 | SUBROUTINE TRIVM ( X, DX, RVAL, VALFLG, NVF, NIVM, XIV0, |
---|
| 5350 | * NDIAG, IOU, IERR ) |
---|
| 5351 | C |
---|
| 5352 | C Subroutine to test real independent variable marks to see if they are |
---|
| 5353 | C monotonic and if they are recorded at the proper interval. |
---|
| 5354 | C |
---|
| 5355 | C Required routines: L3RVAL, TSTDX, TMON3. |
---|
| 5356 | C |
---|
| 5357 | C History: |
---|
| 5358 | C 91-06-26 (SEG) Improved DX tests. |
---|
| 5359 | C |
---|
| 5360 | CHARACTER*5 SUBFLG |
---|
| 5361 | CHARACTER*(*) VALFLG |
---|
| 5362 | C |
---|
| 5363 | DIMENSION RVAL( * ), TVAL( 2 ) |
---|
| 5364 | C |
---|
| 5365 | DATA NSF / 5 / |
---|
| 5366 | DATA SUBFLG / 'TRIVM' / |
---|
| 5367 | C |
---|
| 5368 | IF( IERR .EQ. 0 ) THEN |
---|
| 5369 | NIVM = NIVM + 1 |
---|
| 5370 | CALL L3RVAL ( X, NIVM, RVAL, XIV0 ) |
---|
| 5371 | CALL TMON3 ( RVAL, MIN0(NIVM,3), DX, SUBFLG, NSF, |
---|
| 5372 | * VALFLG, NVF, NBAD, IOU ) |
---|
| 5373 | NDIAG = NDIAG + NBAD |
---|
| 5374 | ENDIF |
---|
| 5375 | TVAL(1) = XIV0 |
---|
| 5376 | TVAL(2) = RVAL(MIN0(3,NIVM)) |
---|
| 5377 | CALL TSTDX ( TVAL, MIN0(NIVM-1,2), NIVM, DX, SUBFLG, NSF, |
---|
| 5378 | * VALFLG, NVF, NDIAG, IOU ) |
---|
| 5379 | RETURN |
---|
| 5380 | END |
---|
| 5381 | SUBROUTINE TSTDX ( X, NXP, NX, DX, SUBFLG, NSF, VALFLG, NVF, |
---|
| 5382 | * NDIAG, IOU ) |
---|
| 5383 | C |
---|
| 5384 | C Subroutine to test vector X to see if its values are uniformly |
---|
| 5385 | C spaced. |
---|
| 5386 | C NXP is the number of values of X passed to this routine (could be |
---|
| 5387 | C just the first and last value), whereas NX is the actual |
---|
| 5388 | C number of defined values of X. |
---|
| 5389 | C This routine only tests to see if NX = ( X(NX) - X(1) ) / DX + 1 |
---|
| 5390 | C so that the index of a particular X(I) can be calculated as |
---|
| 5391 | C I = ( X(I) - X(1) ) / DX + 1 |
---|
| 5392 | C where I is evaluated as the nearest integer to the term on the rhs. |
---|
| 5393 | C |
---|
| 5394 | C Required routines: None. |
---|
| 5395 | C |
---|
| 5396 | C History: |
---|
| 5397 | C 91-06-26 (SEG) Modified DX tests to loop over NXP-1 values of X, and |
---|
| 5398 | C only test for ICAL=I. |
---|
| 5399 | C |
---|
| 5400 | CHARACTER*(*) SUBFLG |
---|
| 5401 | CHARACTER*(*) VALFLG |
---|
| 5402 | C |
---|
| 5403 | DIMENSION X( * ) |
---|
| 5404 | C |
---|
| 5405 | C |
---|
| 5406 | IF( NXP .LT. 2 .OR. DX .EQ. 0.0 ) RETURN |
---|
| 5407 | IF( NXP .EQ. 2 ) THEN |
---|
| 5408 | NCAL = INT( (X(NXP)-X(1))/DX + 0.5 ) + 1 |
---|
| 5409 | IF( NCAL .NE. NX ) THEN |
---|
| 5410 | WRITE( IOU,* ) |
---|
| 5411 | * ' **TSTDX error--Non-uniform ',VALFLG(1:NVF),' interval' |
---|
| 5412 | WRITE( IOU,* ) ' TSTDX called by ',SUBFLG(1:NSF) |
---|
| 5413 | WRITE( IOU,* ) ' NCAL,NX=', NCAL, NX |
---|
| 5414 | WRITE( IOU,* ) ' X(1),X(NX),DX=', X(1),X(NXP),DX |
---|
| 5415 | NDIAG = NDIAG + 1 |
---|
| 5416 | ENDIF |
---|
| 5417 | ELSE |
---|
| 5418 | DO 40 I=2,NXP |
---|
| 5419 | ICAL = INT( (X(I)-X(1))/DX + 0.5 ) + 1 |
---|
| 5420 | IF( ICAL .NE. I ) THEN |
---|
| 5421 | WRITE( IOU,* ) |
---|
| 5422 | * ' **TSTDX error--Non-uniform ',VALFLG(1:NVF),' interval' |
---|
| 5423 | WRITE( IOU,* ) ' TSTDX called by ',SUBFLG(1:NSF) |
---|
| 5424 | WRITE( IOU,* ) ' ICAL,I=', ICAL, I |
---|
| 5425 | WRITE( IOU,* ) ' NXP,NX=', NXP, NX |
---|
| 5426 | WRITE( IOU,* ) ' X(1),X(I),DX=', X(1),X(I),DX |
---|
| 5427 | NDIAG = NDIAG + 1 |
---|
| 5428 | ENDIF |
---|
| 5429 | 40 CONTINUE |
---|
| 5430 | ENDIF |
---|
| 5431 | RETURN |
---|
| 5432 | END |
---|