1 SUBROUTINE NAMER(KAND,IUNIT,NLNAME,LENNLN,VNAME,DVNAME,LENVN, 2 1 NUMVN,VDIME,COMBLK,MAXCOM,LOC,IEOF) 3C 4C*** SIMULATE NAMELIST INPUT. THE FILE ON IUNIT IS READ UNTIL THE 5C*** NAMELIST DEFINED IN NLNAME IS FOUND. IF FOUND, IT IS READ AND 6C*** THE CONSTANTS ASSOCIATED WITH EACH VARIABLE ARE SET INTO THE 7C*** ARRAY COMBLK. IUNIT IS NOT REWOUND BEFORE OR AFTER EXECUTION. 8C*** ALL ERROR MESSAGES ARE PRINTED TO UNIT IO (SET TO 6). 9C 10C KAND - NAMELIST DELIMITER ($ ON CDC AND VAX, & ON IBM AND OTHER) 11C (BUT CAN BE SPECIFIED TO BE ANY UNIQUE CHARACTER) 12C IUNIT - TAPE UNIT FOR READING 13C NLNAME - NAMELIST NAME TO FIND AND READ 14C LENNLN - NUMBER OF CHARACTERS IN NAMELIST NAME (DIMENSION OF NLNAME) 15C VNAME - VARIABLE NAMES FOR THIS NAMELIST (AN ARRAY) 16C DVNAME - DIMENSION OF VNAME ARRAY 17C LENVN - ARRAY WHICH DEFINES THE NUMBER OF CHARACTERS IN EACH 18C VARIABLE NAME 19C NUMVN - NUMBER OF VARIABLE NAMES DEFINED 20C VDIME - NUMBER OF CONSTANTS PERMITTED FOR EACH VARIABLE 21C (DIMENSION OF EACH VARIABLE; USE NEGATIVE FOR LOGICAL 22C VARIABLES) 23C COMBLK - STARTING LOCATION FOR STORING INPUTS 24C (USUALLY THE FIRST LOCATION OF A COMMON BLOCK) 25C MAXCOM - MAXIMUM DIMENSION OF STORAGE ARRAY 26C (USUALLY THE LENGTH OF THE COMMON BLOCK) 27C LOC - POINTER TO STORAGE ARRAY FOR THE STARTING LOCATION 28C OF EACH INPUT VARIABLE (IF ZERO THE CONSTANT IS NOT STORED) 29C IEOF - .TRUE. IF AN END-OF-FILE WAS DETECTED DURING READ 30C 31C*** NOTES - 32C 33C*** ALL INPUT STRING ARRAYS MUST BE DECLARED INTEGER 34C 35C*** ALL VARIABLES ARE ASSUMMED TO BE REAL; IF VDIME IS NEGATIVE 36C*** THE VARIABLE IS ASSUMMED TO BE LOGICAL. ALTHOUGH THE CODE IS 37C*** DESIGNED TO HANDLE INTEGERS AS WELL, THIS OPTION IS NOT 38C*** CURRENTLY USED. IT CAN BE ACTIVATED BY PASSING ANOTHER ARRAY, 39C*** VTYPE, TO DEFINE THE TYPE OF VARIABLE, WITH THE CODE 40C*** 0=LOGICAL, 1=INTEGER, OR 2=REAL; THEN REPLACE THE NAME VTYPE 41C*** WITH THE NAME VTYPE(NVN) IN THE REMAINING CODE. 42C 43C*** THIS ROUTINE CAN BE USED AS A NAMELIST ERROR CHECKER BY SETTING 44C*** THE ARRAY LOC TO ALL ZEROS. THE VARIABELS AND CONSTANTS WILL 45C*** BE READ, BUT THE CONSTANTS NOT STORED. 46C 47 INTEGER EQUAL,COMMA,BLANK,VNAME,DVNAME,VTYPE,VDIME,PARL,PARR, 48 1 CARET 49C 50 LOGICAL IEOF,LANS,SEARCH,FOUND,IEND 51C 52 DIMENSION NLNAME(LENNLN),VNAME(DVNAME),LENVN(NUMVN), 53 1 VDIME(NUMVN),COMBLK(MAXCOM),LOC(NUMVN) 54 DIMENSION INUMS(13),KOL(80),INAME(80),IDIM(80),INLN(80), 55 1 ICONST(80),KERR(80) 56C 57 DATA BLANK / 4H / 58 DATA EQUAL / 4H= / 59 DATA COMMA / 4H, / 60 DATA PARL / 4H( / 61 DATA PARR / 4H) / 62 DATA CARET / 4H / 63 DATA INUMS / 4H0 ,4H1 ,4H2 ,4H3 ,4H4 ,4H5 ,4H6 , 64 1 4H7 ,4H8 ,4H9 ,4H+ ,4H- ,4H. / 65 DATA IO / 6 / 66C 67C****************************************************************** 68C*** STAGE 1 - READ CARD AND CHECK FOR KAND AS FIRST CHARACTER *** 69C****************************************************************** 70C 71 1000 IEND=.FALSE. 72 DO 1010 I=1,80 73 INLN(I)=BLANK 74 KERR(I)=BLANK 75 1010 CONTINUE 76C 77C*** READ CARD FROM IUNIT 78C 79 1020 CALL READCD(IUNIT, KOL, IEOF) 80 IF(IEOF)GO TO 1290 81C 82C*** SKIP LEADING BLANKS 83C 84 ICOL=1 85 CALL SKIPBL(KOL, ICOL) 86 IF(ICOL .GT. 80)GO TO 1020 87C 88C*** LOOK FOR KAND FIRST, ELSE READ NEXT CARD 89C 90 IF(KOL(ICOL) .NE. KAND)GO TO 1020 91C 92C******************************************************** 93C*** STAGE 2 - CHECK IF NAMELIST READ IS ONE DESIRED *** 94C******************************************************** 95C 96C ... EXTRACT NAMELIST NAME TO BLANK 97C 98 ICOL=ICOL+1 99 LCOL=ICOL 100 IECOL=ICOL 101 CALL FINDCH(KOL, BLANK, LCOL) 102 IF(LCOL .EQ. ICOL)GO TO 1040 103C 104 CALL EXTRST(KOL, ICOL, LCOL-1, INLN) 105C 106C ... CHECK FOR NAME MATCH 107C 108 DO 1030 I=1,LENNLN 109 IF(INLN(I) .NE. NLNAME(I))GO TO 1050 110 1030 CONTINUE 111 ICOL=LCOL 112 GO TO 1060 113C 114C*** KAND FOUND BUT NO NAMELIST NAME FOUND 115C 116 1040 CONTINUE 117C 118 WRITE(IO,1310)(KOL(I),I=1,80) 119 KERR(IECOL)=CARET 120 WRITE(IO,1410)(KERR(I),I=1,80) 121 GO TO 1300 122C 123C*** NAMELIST NAME DESIRED NOT FOUND, READ UNTIL KAND SEEN AGAIN 124C*** (SKIP UNTIL END OF THIS NAMELIST INPUT) 125C 126 1050 CALL FINDCH(KOL, KAND, ICOL) 127 IF(ICOL .LE. 80)GO TO 1000 128C 129C ... READ CARD FROM IUNIT 130C 131 CALL READCD(IUNIT, KOL, IEOF) 132 IF(IEOF)GO TO 1290 133 ICOL=1 134 GO TO 1050 135C 136C**************************************** 137C*** STAGE 3 - EXTRACT VARIABLE NAME *** 138C**************************************** 139C 140 1060 SEARCH=.TRUE. 141 IOFF=0 142C 143 DO 1070 I=1,80 144 INAME(I)=BLANK 145 IDIM(I)=BLANK 146 KERR(I)=BLANK 147 1070 CONTINUE 148C 149C ... SKIP BLANKS 150C 151 CALL SKIPBL(KOL, ICOL) 152C 153 IF(ICOL .LT. 81)GO TO 1080 154C 155C ... READ CARD FROM IUNIT 156C 157 CALL READCD(IUNIT, KOL, IEOF) 158 IF(IEOF)GO TO 1290 159 ICOL=1 160C 161 CALL SKIPBL(KOL, ICOL) 162C 163 1080 IF(KOL(ICOL) .EQ. KAND .OR. IEND)GO TO 1290 164C 165C ... EXTRACT TO = 166C 167 LCOL=ICOL 168 IECOL=ICOL 169 CALL FINDCH(KOL, EQUAL, LCOL) 170C 171 IF(LCOL .LT. 81)GO TO 1090 172C 173 WRITE(IO,1320)(KOL(I),I=1,80) 174 KERR(IECOL)=CARET 175 WRITE(IO,1410)(KERR(I),I=1,80) 176 GO TO 1300 177C 178 1090 KNAME=ICOL 179 IECOL=KNAME 180 CALL EXTRST(KOL, ICOL, LCOL-1, INAME) 181C 182C ... LOOK FOR ( IN VARIABLE STRING 183C 184 KK=1 185 CALL FINDCH(INAME, PARL, KK) 186 IF(KK .GT. 80)GO TO 1130 187C 188C ... HAVE SUBSCRIPT DEFINED, NOW LOOK FOR ) 189C 190 LL=KK 191 CALL FINDCH(INAME, PARR, LL) 192C 193 IF(LL .LT. 81)GO TO 1100 194C 195 WRITE(IO,1330)(KOL(I),I=1,80) 196 KERR(IECOL)=CARET 197 WRITE(IO,1410)(KERR(I),I=1,80) 198 GO TO 1300 199C 200C ... EXTRACT SUBSCRIPT (OFFSET) 201C 202 1100 CALL EXTRST(INAME, KK+1, LL-1, IDIM) 203 KSUB=KNAME+KK 204 IECOL=KSUB 205C 206C ... BLANK ( TO ) IN VARIABLE NAME 207C 208 DO 1110 I=KK,LL 209 INAME(I)=BLANK 210 1110 CONTINUE 211C 212C ... CONVERT OFFSET 213C 214 CALL TOINT(IDIM, IOFF, IERR) 215C 216C ... CHECK IF SUBSCRIPT VALID 217C 218 IF(.NOT.(IERR .NE. 0 .OR. IOFF .LT. 1))GO TO 1120 219C 220 WRITE(IO,1370)(KOL(I),I=1,80) 221 KERR(IECOL)=CARET 222 WRITE(IO,1410)(KERR(I),I=1,80) 223 GO TO 1300 224C 225 1120 IOFF=IOFF-1 226C 227 1130 CONTINUE 228C 229 ICOL=LCOL+1 230C 231 1140 IF(KOL(ICOL) .EQ. KAND)IEND=.TRUE. 232C 233 DO 1150 I=1,80 234 ICONST(I)=BLANK 235 1150 CONTINUE 236C 237C*********************************** 238C*** STAGE 4 - EXTRACT CONSTANT *** 239C*********************************** 240C 241C ... EXTRACT TO COMMA OR KAND 242C 243 LCOL=ICOL 244 KCONS=ICOL 245 IECOL=KCONS 246 CALL FINDCH(KOL, COMMA, LCOL) 247C 248 IF(LCOL .LT. 81)GO TO 1160 249C 250C ... COMMA NOT THERE, SEARCH FOR KAND 251C 252 LCOL=ICOL 253 CALL FINDCH(KOL, KAND, LCOL) 254C 255 IF(LCOL .LT. 81)IEND=.TRUE. 256 IF(LCOL .LT. 81)GO TO 1160 257C 258C ... NEITHER COMMA NOR KAND, ASSUME COMMA 259C 260C CALL FINDCH(KOL, BLANK, IECOL) 261C WRITE(IO,1340)KAND,(KOL(I),I=1,80) 262C KERR(IECOL)=CARET 263C WRITE(IO,1410)(KERR(I),I=1,80) 264C 265 1160 CALL EXTRST(KOL, ICOL, LCOL-1, ICONST) 266C 267C ... EXTRACT REPEAT COUNT SPECIFIED IN CONSTANT 268C 269 IECOL=KCONS 270 CALL REPTCT(ICONST, IREPT, IERR) 271C 272 IF(IERR .EQ. 0 .AND. IREPT .GT. 0)GO TO 1170 273C 274 WRITE(IO,1390)(KOL(I),I=1,80) 275 KERR(IECOL)=CARET 276 WRITE(IO,1410)(KERR(I),I=1,80) 277 GO TO 1300 278C 279 1170 ICOL=LCOL+1 280C 281C************************************* 282C*** STAGE 5 - FIND VARIABLE NAME *** 283C************************************* 284C 285C ... SEARCH FOR VARIABLE NAME IN VNAME ARRAY 286C 287 IECOL=KNAME 288 IF(SEARCH)CALL FINDVN(NUMVN, LENVN, INAME, VNAME, DVNAME, NVN, 289 1 FOUND) 290C 291 IF(.NOT.(SEARCH .AND. .NOT. FOUND))GO TO 1180 292C 293 WRITE(IO,1350)(KOL(I),I=1,80) 294 KERR(IECOL)=CARET 295 WRITE(IO,1410)(KERR(I),I=1,80) 296 GO TO 1300 297C 298C ... CHECK VARIABLE DIMENSION LIMIT 299C 300 1180 IECOL=KCONS 301C 302 IF(.NOT.((IOFF+1) .GT. IABS(VDIME(NVN))))GO TO 1190 303C 304 WRITE(IO,1370)(KOL(I),I=1,80) 305 KERR(IECOL)=CARET 306 WRITE(IO,1410)(KERR(I),I=1,80) 307 GO TO 1300 308C 309 1190 LANS=.FALSE. 310 IANS=0 311 ANS=0. 312C 313C************************************** 314C*** STAGE 6 - SUBSTITUTE CONSTANT *** 315C************************************** 316C 317C ... CONVERT CONSTANT DEPENDING ON TYPE 318C 319 IECOL=KCONS 320C 321C ... A NEGATIVE DIMENSION MEANS LOGICAL 322C ... ELSE VARIABLE TYPE IS REAL 323C 324 IF(VDIME(NVN) .LT. 0)VTYPE=0 325 IF(VDIME(NVN) .GT. 0)VTYPE=2 326C 327 IF(VTYPE .EQ. 0)CALL TOLOG(ICONST, LANS, IERR) 328 IF(VTYPE .EQ. 1)CALL TOINT(ICONST, IANS, IERR) 329 IF(VTYPE .EQ. 2)CALL TODEC(ICONST, ANS, IERR) 330C 331 IF(IERR .EQ. 0)GO TO 1220 332C 333 IF(VTYPE .EQ. 1)GO TO 1200 334C 335 WRITE(IO,1390)(KOL(I),I=1,80) 336 KERR(IECOL)=CARET 337 WRITE(IO,1410)(KERR(I),I=1,80) 338 GO TO 1300 339C 340 1200 IF(IERR .EQ. 1 .AND. VTYPE .NE. 1)GO TO 1210 341C 342 WRITE(IO,1390)(KOL(I),I=1,80) 343 KERR(IECOL)=CARET 344 WRITE(IO,1410)(KERR(I),I=1,80) 345 GO TO 1300 346C 347 1210 IF(IERR .EQ. 2 .AND. VTYPE .NE. 1)GO TO 1220 348C 349C WRITE(IO,1400)(KOL(I),I=1,80) 350C KERR(IECOL)=CARET 351C WRITE(IO,1410)(KERR(I),I=1,80) 352C 353C ... SUBSTITUTE CONSTANT 354C 355 1220 DO 1250 I=1,IREPT 356C 357C ... CHECK VARIABLE DIMENSION LIMIT 358C 359 IF((I+IOFF) .LE. IABS(VDIME(NVN)))GO TO 1230 360C 361 IECOL=KCONS 362 WRITE(IO,1380)(KOL(J),J=1,80) 363 KERR(IECOL)=CARET 364 WRITE(IO,1410)(KERR(J),J=1,80) 365 GO TO 1300 366C 367 1230 IF(LOC(NVN) .LT. 1)GO TO 1250 368 II=LOC(NVN)+I+IOFF-1 369C 370C ... CHECK DATA BLOCK SIZE LIMIT 371C 372 IF(II .LE. MAXCOM)GO TO 1240 373C 374 WRITE(IO,1360)(KOL(J),J=1,80) 375 KERR(IECOL)=CARET 376 WRITE(IO,1410)(KERR(J),J=1,80) 377 GO TO 1300 378C 379C ... SUBSTITUTE CONSTANT DEPENDING ON TYPE 380C 381 1240 IF(VTYPE .EQ. 0)CALL SUBLOG(COMBLK(II), LANS) 382 IF(VTYPE .EQ. 1)CALL SUBINT(COMBLK(II), IANS) 383 IF(VTYPE .EQ. 2)CALL SUBREA(COMBLK(II), ANS) 384C 385 1250 CONTINUE 386C 387C ... UPDATE OFFSET IN CASE NEXT INPUT IS A CONSTANT INSTEAD OF A 388C ... VARIABLE NAME 389C 390 IOFF=IOFF+IREPT 391C 392C ... CHECK IF NEXT INPUT IS A NUMERIC OR LOGICAL 393C 394 CALL SKIPBL(KOL, ICOL) 395C 396C ... IF KAND PREVIOUSLY DETECTED, EXIT 397C 398 IF(IEND)GO TO 1290 399C 400 IF(ICOL .LT. 81)GO TO 1260 401C 402C ... READ NEXT CARD 403C 404 CALL READCD(IUNIT, KOL, IEOF) 405 IF(IEOF)GO TO 1290 406 ICOL=1 407C 408 CALL SKIPBL(KOL, ICOL) 409C 410C ... CHECK IF NEXT NON-BLANK CHARACTER SPECIFIES A NUMERIC OR 411C ... LOGICAL INPUT 412C 413 1260 DO 1270 I=1,13 414 IF(KOL(ICOL) .EQ. INUMS(I))GO TO 1280 415 1270 CONTINUE 416C 417C ... NO, SEARCH FOR NEXT VARIABLE NAME INPUT 418C 419 IERR=0 420 GO TO 1060 421C 422C ... YES, SEARCH FOR NEXT INPUT CONSTANT 423C 424 1280 SEARCH=.FALSE. 425 IERR=0 426 GO TO 1140 427C 428 1290 CONTINUE 429C 430 RETURN 431C 432 1300 WRITE(IO,1420) 433 STOP 434C 435 1310 FORMAT(26H0*** NAMELIST INPUT ERROR., 436 1 51H ILLEGAL/INCORRECT SPECIFICATION OF NAMELIST NAME., 437 2 /,1X,80A1) 438 1320 FORMAT(26H0*** NAMELIST INPUT ERROR., 439 1 36H NO EQUALS FOLLOWING VARIABLE NAME.,/,1X,80A1) 440 1330 FORMAT(26H0*** NAMELIST INPUT ERROR., 441 1 51H NO CLOSING RIGHT PARENTHESIS IN ARRAY DEFINITION., 442 2 /,1X,80A1) 443C1340 FORMAT(26H0*** NAMELIST INPUT ERROR., 444C 1 26H NO TERMINATING COMMA OR ,A1,16H AFTER CONSTANT., 445C 2 27H A COMMA HAS BEEN ASSUMED.,/,1X,80A1) 446 1350 FORMAT(26H0*** NAMELIST INPUT ERROR., 447 1 32H VARIABLE NAME NOT IN NAMELIST.,/,1X,80A1) 448 1360 FORMAT(26H0*** NAMELIST INPUT ERROR., 449 1 57H ARRAY SUBSCRIPT OR NUMBER OF CONSTANTS EXCEEDS VARIABLE, 450 2 32H DIMENSION OR COMMON BLOCK SIZE.,/,1X,80A1) 451 1370 FORMAT(26H0*** NAMELIST INPUT ERROR., 452 1 34H ILLEGAL/INVALID ARRAY SUBSCRIPT.,/,1X,80A1) 453 1380 FORMAT(26H0*** NAMELIST INPUT ERROR., 454 1 48H REPEAT COUNT EXCEEDS VARIABLE ARRAY DIMENSION.,/,1X,80A1) 455 1390 FORMAT(26H0*** NAMELIST INPUT ERROR., 456 1 49H CONSTANT DOES NOT MATCH TYPE OF INPUT REQUIRED.,/,1X,80A1) 457C1400 FORMAT(26H0*** NAMELIST INPUT ERROR., 458C 1 47H REAL NUMBER SPECIFIED FOR INTEGER, CONVERTED.,/,1X,80A1) 459 1410 FORMAT(1X,80A1) 460 1420 FORMAT(49H0*** EXECUTION TERMINATING DUE TO NAMELIST ERROR.) 461C 462 END 463