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