home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume12 / ffccc / part02 < prev    next >
Text File  |  1990-05-14  |  48KB  |  1,197 lines
  1. Newsgroups: comp.sources.misc
  2. organization: CERN, Geneva, Switzerland
  3. keywords: fortran
  4. subject: v12i088: Floppy - Fortran Coding Convention Checker Part 02/11
  5. from: julian@cernvax.cern.ch (julian bunn)
  6. Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  7.  
  8. Posting-number: Volume 12, Issue 88
  9. Submitted-by: julian@cernvax.cern.ch (julian bunn)
  10. Archive-name: ffccc/part02
  11.  
  12. #!/bin/sh
  13. echo 'Start of Floppy, part 02 of 11:'
  14. echo 'x - DEFSTA.f'
  15. sed 's/^X//' > DEFSTA.f << '/'
  16. X      SUBROUTINE DEFSTA(INDE,ILEN,CNAM,FOK) 
  17. XC For statement class INDE returns length of FORTRAN
  18. XC keyword (ILEN), keyword name (CNAM*25) and logical
  19. XC FOK, which is set if the statement is to be checked   
  20. XC for embedded blanks.  
  21. XC INPUT ; INDE  
  22. XC OUTPUT; ILEN  
  23. XC         CNAM  
  24. XC         FOK   
  25. XC   
  26. X      include 'PARAM.h' 
  27. X      include 'USUNIT.h' 
  28. X      CHARACTER*25 CNAM 
  29. X      LOGICAL FOK   
  30. X      PARAMETER (LFOK=37)   
  31. X      DIMENSION IFOK(LFOK)  
  32. X      CHARACTER CFORTS(MXSTAT)*25   
  33. X      DATA CFORTS(  1)/'ASSIGN                   '/ 
  34. X      DATA CFORTS(  2)/'BACKSPACE                '/ 
  35. X      DATA CFORTS(  3)/'BLOCKDATA                '/ 
  36. X      DATA CFORTS(  4)/'BUFFERIN                 '/ 
  37. X      DATA CFORTS(  5)/'BUFFEROUT                '/ 
  38. X      DATA CFORTS(  6)/'CONTINUE                 '/ 
  39. X      DATA CFORTS(  7)/'CALL                     '/ 
  40. X      DATA CFORTS(  8)/'COMMON                   '/ 
  41. X      DATA CFORTS(  9)/'COMPLEXFUNCTION          '/ 
  42. X      DATA CFORTS( 10)/'COMPLEX                  '/ 
  43. X      DATA CFORTS( 11)/'COMPLEX                  '/ 
  44. X      DATA CFORTS( 12)/'CHARACTERFUNCTION        '/ 
  45. X      DATA CFORTS( 13)/'CHARACTER                '/ 
  46. X      DATA CFORTS( 14)/'CHARACTER                '/ 
  47. X      DATA CFORTS( 15)/'CLOSE                    '/ 
  48. X      DATA CFORTS( 16)/'DATA                     '/ 
  49. X      DATA CFORTS( 17)/'DIMENSION                '/ 
  50. X      DATA CFORTS( 18)/'DO                       '/ 
  51. X      DATA CFORTS( 19)/'DO                       '/ 
  52. X      DATA CFORTS( 20)/'DECODE                   '/ 
  53. X      DATA CFORTS( 21)/'DOUBLEPRECISIONFUNCTION  '/ 
  54. X      DATA CFORTS( 22)/'DOUBLEPRECISION          '/ 
  55. X      DATA CFORTS( 23)/'END                      '/ 
  56. X      DATA CFORTS( 24)/'ENDIF                    '/ 
  57. X      DATA CFORTS( 25)/'ENDFILE                  '/ 
  58. X      DATA CFORTS( 26)/'ENTRY                    '/ 
  59. X      DATA CFORTS( 27)/'EQUIVALENCE              '/ 
  60. X      DATA CFORTS( 28)/'EXTERNAL                 '/ 
  61. X      DATA CFORTS( 29)/'ELSE                     '/ 
  62. X      DATA CFORTS( 30)/'ELSEIF                   '/ 
  63. X      DATA CFORTS( 31)/'ENCODE                   '/ 
  64. X      DATA CFORTS( 32)/'FORMAT                   '/ 
  65. X      DATA CFORTS( 33)/'FUNCTION                 '/ 
  66. X      DATA CFORTS( 34)/'GOTO                     '/ 
  67. X      DATA CFORTS( 35)/'GOTO                     '/ 
  68. X      DATA CFORTS( 36)/'GOTO                     '/ 
  69. X      DATA CFORTS( 37)/'IF                       '/ 
  70. X      DATA CFORTS( 38)/'IF                       '/ 
  71. X      DATA CFORTS( 39)/'IF                       '/ 
  72. X      DATA CFORTS( 40)/'ILLEGAL                  '/ 
  73. X      DATA CFORTS( 41)/'INTEGERFUNCTION          '/ 
  74. X      DATA CFORTS( 42)/'INTEGER                  '/ 
  75. X      DATA CFORTS( 43)/'INTEGER                  '/ 
  76. X      DATA CFORTS( 44)/'IMPLICIT                 '/ 
  77. X      DATA CFORTS( 45)/'INQUIRE                  '/ 
  78. X      DATA CFORTS( 46)/'INTRINSIC                '/ 
  79. X      DATA CFORTS( 47)/'LOGICALFUNCTION          '/ 
  80. X      DATA CFORTS( 48)/'LOGICAL                  '/ 
  81. X      DATA CFORTS( 49)/'LOGICAL                  '/ 
  82. X      DATA CFORTS( 50)/'LEVEL                    '/ 
  83. X      DATA CFORTS( 51)/'NAMELIST                 '/ 
  84. X      DATA CFORTS( 52)/'OPEN                     '/ 
  85. X      DATA CFORTS( 53)/'PRINT                    '/ 
  86. X      DATA CFORTS( 54)/'PARAMETER                '/ 
  87. X      DATA CFORTS( 55)/'PAUSE                    '/ 
  88. X      DATA CFORTS( 56)/'PROGRAM                  '/ 
  89. X      DATA CFORTS( 57)/'PUNCH                    '/ 
  90. X      DATA CFORTS( 58)/'READ                     '/ 
  91. X      DATA CFORTS( 59)/'READ                     '/ 
  92. X      DATA CFORTS( 60)/'REALFUNCTION             '/ 
  93. X      DATA CFORTS( 61)/'REAL                     '/ 
  94. X      DATA CFORTS( 62)/'REAL                     '/ 
  95. X      DATA CFORTS( 63)/'RETURN                   '/ 
  96. X      DATA CFORTS( 64)/'REWIND                   '/ 
  97. X      DATA CFORTS( 65)/'SAVE                     '/ 
  98. X      DATA CFORTS( 66)/'STOP                     '/ 
  99. X      DATA CFORTS( 67)/'SUBROUTINE               '/ 
  100. X      DATA CFORTS( 68)/'WRITE                    '/ 
  101. X      DATA CFORTS( 69)/'ASSIGNMENT               '/ 
  102. X      DATA CFORTS( 70)/'ASSIGNMENT               '/ 
  103. X      DATA CFORTS( 71)/'ASSIGNMENT               '/ 
  104. XC   
  105. X      DATA IFOK /13,31,32,42,48,52,53,54,57,58,59,61, 68,69,70,71,30,34,
  106. X     +35,36,37,38,39,8,9,12,21,22,24,41,47,60,14,43,49,62,11/   
  107. X      FOK = .FALSE. 
  108. X      IF(INDE.GT.MXSTAT.OR.INDE.LT.1) THEN  
  109. X         WRITE(MZUNIT,500)  
  110. X         RETURN 
  111. X      ENDIF 
  112. X      DO 10 I=1,LFOK
  113. X         IF(INDE.EQ.IFOK(I)) RETURN 
  114. X   10 CONTINUE  
  115. X      FOK = .TRUE.  
  116. X      CNAM = CFORTS(INDE)   
  117. X      ILEN = INDEX(CNAM,' ')-1  
  118. X      RETURN
  119. X  500 FORMAT(1X,'!!! NON-FATAL ERROR IN DEFSTA')
  120. X      END   
  121. /
  122. echo 'x - SECPAS.f'
  123. sed 's/^X//' > SECPAS.f << '/'
  124. X      SUBROUTINE SECPAS(NGLOBF,LIMPNO)  
  125. X      include 'PARAM.h' 
  126. X      include 'ALCAZA.h' 
  127. X      include 'CLASS.h' 
  128. X      include 'CURSTA.h' 
  129. X      include 'FLWORK.h' 
  130. X      include 'KEYCOM.h' 
  131. X      include 'TYPDEF.h' 
  132. X      include 'JOBSUM.h' 
  133. X      include 'STATE.h' 
  134. X      include 'FLAGS.h' 
  135. X      include 'USIGNO.h' 
  136. X      include 'USLIST.h' 
  137. X      include 'USGCOM.h' 
  138. X      include 'USSTMT.h' 
  139. X      include 'USUNIT.h' 
  140. X      include 'USARGS.h' 
  141. X      include 'USLTYD.h' 
  142. X      include 'CHECKS.h' 
  143. X      PARAMETER (MNUMP=100) 
  144. X      CHARACTER*(MXNMCH) CNAM,CNAMF,CNAMP(MNUMP)
  145. X      CHARACTER*(NOARG) CSTRIN,CDIM,CDIMN(10)   
  146. X      CHARACTER*(MDIMST) CSTAT  
  147. X      INTEGER ICNAMP(MNUMP),NSEND2(700) 
  148. X      INTEGER IDO(100)  
  149. X      LOGICAL LIMPNO,BTEST  
  150. X      IOSM = 0  
  151. X      IOSP = 0  
  152. X      IOSD = 0  
  153. X      IOSS = 0  
  154. X      IOSO = 0  
  155. X      IOSE = 0  
  156. X      NSTFUN = 0
  157. X      NUMP = 0  
  158. X      NUMF = 0  
  159. X      NSTFIN = 0
  160. X      DO 10 II=1,MNUMP  
  161. X         CNAMP(II)='        '   
  162. X         ICNAMP(II) = 0 
  163. X   10 CONTINUE  
  164. X      DO 20 I=1,100 
  165. X         IDO(I) = 0 
  166. X   20 CONTINUE  
  167. X      MNTDO=0   
  168. X      MNTIF=0   
  169. X      NKALL=0   
  170. X      LIMPNO = .FALSE.  
  171. X      DO 330 IST=1,NSTAMM   
  172. X         ICL1 = ICLASS(IST,1)   
  173. X         ICL2 = ICLASS(IST,2)   
  174. X         IF(ICL1.EQ.0.OR.ICL1.EQ.999)                           GOTO 330
  175. X         NST = NFLINE(IST)  
  176. X         NFI = NLLINE(IST)  
  177. XC GET STATEMENT NAMES   
  178. X         ICURCL(1)=ICL1 
  179. X         ICURCL(2)=ICL2 
  180. X         ISNAME = IRNAME+NRNAME 
  181. X         CALL EXTRAC(IST,'FULL')
  182. X         CALL GETALL
  183. XC make check for MIXED MODE EXPRESSIONS 
  184. X         IF(LCHECK(37)) CALL MIXMOD(NGLOBF) 
  185. XC if TREE info, find current DO/IF level. After Grote.  
  186. X         IF(ACTION(29)) THEN
  187. X            ICLE=ISTMDS(6,ICURCL(1))
  188. X            IF(ICLE.EQ.39) THEN 
  189. X               MNTIF=MNTIF+1
  190. X            ELSEIF(ICLE.EQ.27) THEN 
  191. X               MNTIF=MNTIF-1
  192. X            ELSEIF(ICLE.EQ.20) THEN 
  193. X               IF(MNTDO.LT.100) THEN
  194. X                  MNTDO=MNTDO+1 
  195. X                  CALL GETINT(SSTA,1,NCHST,KFCH,KLCH,NN)
  196. X                  IDO(MNTDO)=NN 
  197. X               ENDIF
  198. X            ELSEIF(MNTDO.GT.0) THEN 
  199. X               K=NEXTIN(SIMA(NFLINE(NSTREF)),1,5)   
  200. X               KST=MNTDO
  201. X               DO 30 I=KST,1,-1 
  202. X                  IF(IDO(I).NE.K)                                GOTO 40
  203. X                  MNTDO=MNTDO-1 
  204. X   30          CONTINUE 
  205. X   40          CONTINUE 
  206. X            ENDIF   
  207. XC check for CALL
  208. X            IF(ICLE.EQ.7) THEN  
  209. X               IF(NKALL.LT.MKALL) THEN  
  210. X                  NKALL = NKALL + 1 
  211. X                  CKALLN(NKALL) = SNAMES(ISNAME+1)  
  212. X                  KALLIF(NKALL) = MNTIF 
  213. X                  KALLDO(NKALL) = MNTDO 
  214. X               ENDIF
  215. X            ELSE IF(ICL1.EQ.IIF) THEN   
  216. X               IF(ISTMDS(6,ICURCL(2)).EQ.7) THEN
  217. X                  IF(NKALL.LT.MKALL) THEN   
  218. X                     INDB=INDEX(SSTA,'(')+1 
  219. X                     CALL SKIPLV(SSTA,INDB,NCHST,.FALSE.,IEN,ILEV)  
  220. X                     INDB=IEN+1 
  221. X                     IFOU=999   
  222. X                     DO 50 ISN=1,NSNAME 
  223. X                        IF(NSSTRT(ISN).GT.INDB.AND.NSSTRT(ISN).LT.IFOU) 
  224. X     +                  THEN
  225. X                           IFOU=NSSTRT(ISN) 
  226. X                           ISNF=ISN 
  227. X                        ENDIF   
  228. X   50                CONTINUE   
  229. X                     NKALL = NKALL + 1  
  230. X                     CKALLN(NKALL) = SNAMES(ISNAME+ISNF)
  231. X                     KALLIF(NKALL) = MNTIF+1
  232. X                     KALLDO(NKALL) = MNTDO  
  233. X                  ENDIF 
  234. X               ENDIF
  235. X            ENDIF   
  236. XC check for use of FUNCTIONs
  237. X            IF(ICLE.EQ.2.OR.ISTMDS(6,ICURCL(2)).EQ.2) THEN  
  238. XC this is an assignment statement   
  239. X               DO 80 IS=1,NSNAME
  240. X                  DO 60 IR=1,NRNAME 
  241. X                     IF(SNAMES(IR+IRNAME).NE.SNAMES(IS+ISNAME))  GOTO 60
  242. X                                                                 GOTO 70
  243. X   60             CONTINUE  
  244. X                                                                 GOTO 80
  245. X   70             IF(.NOT.BTEST(NAMTYP(IR+IRNAME),16))           GOTO 80
  246. X                  IF(NKALL.GE.MKALL)                             GOTO 90
  247. X                  NKALL = NKALL+1   
  248. X                  CKALLN(NKALL) = SNAMES(IR+IRNAME) 
  249. X                  KALLIF(NKALL) = MNTIF 
  250. X                  KALLDO(NKALL) = MNTDO 
  251. X                  IF(ICLE.EQ.IIF) KALLIF(NKALL) = MNTIF+1   
  252. X   80          CONTINUE 
  253. X   90          CONTINUE 
  254. X            ENDIF   
  255. X         ENDIF  
  256. XC remove all blanks in statement
  257. X         DO 100 IS=1,NSNAME 
  258. X            NSEND2(IS)=NSEND(IS)
  259. X  100    CONTINUE   
  260. X         NCHAS = 0  
  261. X         DO 120 IC=1,NCHST  
  262. X            IF(SSTA(IC:IC).EQ.' ') THEN 
  263. XC update NSEND into NSEND2  
  264. X               DO 110 ISN=1,NSNAME  
  265. X                  IF(NSEND2(ISN).GT.IC) NSEND2(ISN)=NSEND2(ISN)-1   
  266. X  110          CONTINUE 
  267. X                                                                GOTO 120
  268. X            ENDIF   
  269. X            NCHAS = NCHAS + 1   
  270. X            CSTAT(NCHAS:NCHAS) = SSTA(IC:IC)
  271. X  120    CONTINUE   
  272. XC   
  273. XC trap IMPLICIT NONE or IMPLICIT LOGICAL(A-Z)   
  274. X         IF(INDEX(CSTAT,'IMPLICITNONE').NE.0) LIMPNO=.TRUE. 
  275. X         IF(INDEX(CSTAT,'IMPLICITLOGICAL(A-Z)').NE.0) LIMPNO=.TRUE. 
  276. X         IF(ICL1.EQ.ILL)                                        GOTO 330
  277. XC   
  278. XC At module start, find argument list if any
  279. X         IF(LMODUL(ICL1)) THEN  
  280. X            NARGS = NSNAME - 1  
  281. X            DO 130 IA=1,NARGS   
  282. X               CARGNM(IA) = SNAMES(ISNAME+1+IA) 
  283. X  130       CONTINUE
  284. X         ENDIF  
  285. XC   
  286. XC within module, check for dimensionality of items in argument list 
  287. X         IF(ICL1.EQ.0.OR.ICL1.EQ.999.OR.LIFF(ICL1))             GOTO 250
  288. X         DO 240 ISN=1,NSNAME
  289. XC find name in routine list for NAMTYP check
  290. X            DO 140 IRN=1,NRNAME 
  291. X               IF(SNAMES(IRN+IRNAME).EQ.SNAMES(ISN+ISNAME))     GOTO 150
  292. X  140       CONTINUE
  293. X                                                                GOTO 240
  294. X  150       NTYP = NAMTYP(IRN+IRNAME)   
  295. X            CNAM = ' '  
  296. X            CNAM = SNAMES(ISN+ISNAME)   
  297. X            ILEN1 = INDEX(CNAM,' ')-1   
  298. X            IF(ILEN1.EQ.-1) ILEN1 = MXNMCH  
  299. X            IFOU = 0
  300. X            DO 160 IARG=1,NARGS 
  301. X               ILEN2 = INDEX(CARGNM(IARG),' ')-1
  302. X               IF(ILEN2.EQ.-1) ILEN2 = MXNMCH   
  303. X               IF(ILEN2.NE.ILEN1)                               GOTO 160
  304. X               IF(CARGNM(IARG)(:ILEN2).NE.CNAM(:ILEN1))         GOTO 160
  305. X               IFOU = IARG  
  306. X                                                                GOTO 170
  307. X  160       CONTINUE
  308. X  170       IF(IFOU.EQ.0)                                       GOTO 240
  309. XC found in argument list
  310. XC   
  311. X            IF(.NOT.BTEST(NTYP,17).AND..NOT.BTEST(NTYP,5)) THEN 
  312. XC fill info in USARGS   
  313. X               IF(ACTION(29)) THEN  
  314. X                  IF(CARGTY(IFOU).EQ.' ') THEN  
  315. X                     IF(BTEST(NTYP,4)) CARGTY(IFOU)='DOUBLEPRECISION'   
  316. X                     LG = INDEX(CARGTY(IFOU),' ')   
  317. X                     IF(BTEST(NTYP,0)) CARGTY(IFOU)(LG:)='INTEGER'  
  318. X                     IF(BTEST(NTYP,1)) CARGTY(IFOU)(LG:)='REAL' 
  319. X                     IF(BTEST(NTYP,2)) CARGTY(IFOU)(LG:)='LOGICAL'  
  320. X                     IF(BTEST(NTYP,3)) CARGTY(IFOU)(LG:)='COMPLEX'  
  321. X                  ENDIF 
  322. X               ENDIF
  323. X                                                                GOTO 240
  324. X            ENDIF   
  325. X            IF(LDIMEN(ICL1)) THEN   
  326. XC dimensioned or character variable 
  327. XC first treat CHARACTER*() cases
  328. XC   
  329. X               IC1 = 13 
  330. X               IF(INDEX(CSTAT,'CHARACTER*').NE.0) THEN  
  331. X                  IC1 = 12  
  332. X                  IPOSS = INDEX(CSTAT(:NCHAS),'CHARACTER*')+10  
  333. X                  ILEV = 0  
  334. X                  CDIM = ' '
  335. X                  N = 0 
  336. X                  DO 180 IC=IPOSS,NCHAS 
  337. X                     IF(CSTAT(IC:IC).EQ.'(') THEN   
  338. X                        ILEV = ILEV + 1 
  339. X                        IF(N.GT.0.AND.ILEV.EQ.1)                GOTO 190
  340. X                        IF(ILEV.EQ.1)                           GOTO 180
  341. X                     ELSE IF(CSTAT(IC:IC).EQ.')') THEN  
  342. X                        ILEV = ILEV - 1 
  343. X                        IF(ILEV.EQ.0)                           GOTO 190
  344. X                     ENDIF  
  345. X                     N = N+1
  346. X                     CDIM(N:N) = CSTAT(IC:IC)   
  347. X  180             CONTINUE  
  348. X  190             CONTINUE  
  349. XC fill info in USARGS   
  350. X                  IF(N.EQ.0) THEN   
  351. X                     N = 1  
  352. X                     CDIM(1:1) = '?'
  353. X                  ENDIF 
  354. X                  IF(ACTION(29)) THEN   
  355. X                     CARGTY(IFOU) = 'CHARACTER*('//CDIM(:N)//')'
  356. X                     NARGDI(IFOU) = 0   
  357. X                  ENDIF 
  358. X                  IF(LCHECK(38).AND.CDIM(1:1).NE.'*') THEN  
  359. X                     WRITE(MZUNIT,500) CNAM 
  360. X                     NGLOBF = NGLOBF + 1
  361. X                                                                GOTO 240
  362. X                  ENDIF 
  363. X               ENDIF
  364. XC   
  365. XC now CHARACTER with length later or modified length
  366. X               IPOS = NSEND2(ISN)+1 
  367. X               IF(LCHARC(ICL1).OR.IC1.EQ.12) THEN   
  368. X                  N = 0 
  369. X                  ILEV = 0  
  370. X                  CDIM = ' '
  371. X                  ISTAR = 0 
  372. X                  DO 200 IC=IPOS,NCHAS  
  373. X                     IF(CSTAT(IC:IC).EQ.'(') THEN   
  374. X                        ILEV = ILEV + 1 
  375. X                                                                GOTO 200
  376. X                     ELSE IF(CSTAT(IC:IC).EQ.')') THEN  
  377. X                        ILEV = ILEV - 1 
  378. X                                                                GOTO 200
  379. X                     ELSE IF(CSTAT(IC:IC).EQ.'*') THEN  
  380. X                        IF(ILEV.EQ.0) THEN  
  381. X                           ISTAR = 1
  382. X                                                                GOTO 200
  383. X                        ENDIF   
  384. X                     ENDIF  
  385. X                     IF(ILEV.EQ.0.AND.CSTAT(IC:IC).EQ.',')      GOTO 210
  386. X                     IF(ISTAR.EQ.0)                             GOTO 200
  387. X                     N = N + 1  
  388. X                     CDIM(N:N) = CSTAT(IC:IC)   
  389. X  200             CONTINUE  
  390. X  210             CONTINUE  
  391. XC fill info in USARGS   
  392. X                  IF(N.EQ.0) THEN   
  393. X                     N = 1  
  394. X                     CDIM(:1) = '?' 
  395. X                  ENDIF 
  396. X                  IF(ACTION(29)) THEN   
  397. X                     CARGTY(IFOU) = 'CHARACTER*('//CDIM(:N)//')'
  398. X                     NARGDI(IFOU) = 0   
  399. X                  ENDIF 
  400. X                  IF(LCHECK(39)) THEN   
  401. X                     IF((CDIM(1:1).NE.'*'.AND.IC1.EQ.13).OR. (N.GT.0.AND
  402. X     +               .IC1.EQ.12.AND.CDIM(1:1).NE.'*')) THEN 
  403. X                        WRITE(MZUNIT,500) CNAM  
  404. X                        NGLOBF = NGLOBF + 1 
  405. X                                                                GOTO 240
  406. X                     ENDIF  
  407. X                  ENDIF 
  408. X                                                                GOTO 240
  409. X               ENDIF
  410. XC a dimensioned non-character variable  
  411. X               IPOS2 = INDEX(CSTAT(IPOS:NCHAS),'(')+IPOS
  412. X               IF(IPOS2.EQ.IPOS)                                GOTO 240
  413. X               IF(IPOS2.NE.IPOS+1)                              GOTO 240
  414. X               CALL SKIPLV(CSTAT,IPOS2,NCHAS,.FALSE.,IEN,ILEV)  
  415. XC dimension clause spans IPOS2 to IEN-1 
  416. X               ISTA = IPOS2 
  417. X               IFIN = IEN-1 
  418. X               NDIM = 0 
  419. X               CDIM = ' '   
  420. X               N = 0
  421. X               DO 220 IC=ISTA,IFIN  
  422. X                  IF(CSTAT(IC:IC).EQ.',') THEN  
  423. X                     NDIM = NDIM + 1
  424. X                     CDIMN(NDIM) = ' '  
  425. X                     CDIMN(NDIM) = CDIM(:N) 
  426. X                     CDIM = ' ' 
  427. X                     N = 0  
  428. X                                                                GOTO 220
  429. X                  ENDIF 
  430. X                  N = N + 1 
  431. X                  CDIM(N:N) = CSTAT(IC:IC)  
  432. X  220          CONTINUE 
  433. X               IF(N.EQ.0) THEN  
  434. X                  N = 1 
  435. X                  CDIM(1:1) = '?'   
  436. X               ENDIF
  437. X               NDIM = NDIM + 1  
  438. X               CDIMN(NDIM) = ' '
  439. X               CDIMN(NDIM) = CDIM(:N)   
  440. X               CARGTY(IFOU) = ' '   
  441. XC fill info in USARGS   
  442. X               IF(ACTION(29)) THEN  
  443. X                  IF(BTEST(NTYP,4)) CARGTY(IFOU)='DOUBLEPRECISION'  
  444. X                  LG = INDEX(CARGTY(IFOU),' ')  
  445. X                  IF(BTEST(NTYP,0)) CARGTY(IFOU)(LG:)='INTEGER' 
  446. X                  IF(BTEST(NTYP,1)) CARGTY(IFOU)(LG:)='REAL'
  447. X                  IF(BTEST(NTYP,2)) CARGTY(IFOU)(LG:)='LOGICAL' 
  448. X                  IF(BTEST(NTYP,3)) CARGTY(IFOU)(LG:)='COMPLEX' 
  449. X    
  450. X                  NARGDI(IFOU) = NDIM   
  451. X                  DO 230 I=1,NDIM   
  452. X                     CDIM=CDIMN(I)  
  453. X                     ICOLON=INDEX(CDIM,':') 
  454. X                     IF(ICOLON.NE.0) THEN   
  455. X                        CARGDI(I,1,IFOU)=CDIM(1:ICOLON-1)   
  456. X                        CARGDI(I,2,IFOU)=CDIM(ICOLON+1:INDEX(CDIM,' ')  
  457. X     +                  -1) 
  458. X                     ELSE   
  459. X                        CARGDI(I,1,IFOU)='1'
  460. X                        CARGDI(I,2,IFOU)=CDIM   
  461. X                     ENDIF  
  462. X  230             CONTINUE  
  463. X               ENDIF
  464. X               IF(NDIM.EQ.0)                                    GOTO 240
  465. X               ICOLON = INDEX(CDIMN(NDIM),':')  
  466. X               IF(ICOLON.NE.0) THEN 
  467. X                  ILEN = INDEX(CDIMN(NDIM),' ')-1   
  468. X                  IF(ILEN.EQ.-1) ILEN = NOARG   
  469. X                  CDIM = CDIMN(NDIM)(ICOLON+1:ILEN) 
  470. X               ELSE 
  471. X                  CDIM = CDIMN(NDIM)
  472. X               ENDIF
  473. X               IF(LCHECK(44).AND.CDIM(1:1).NE.'*') THEN 
  474. X                  WRITE(MZUNIT,510) CNAM
  475. X                  NGLOBF = NGLOBF + 1   
  476. X                                                                GOTO 240
  477. X               ENDIF
  478. X            ENDIF   
  479. X  240    CONTINUE   
  480. X  250    CONTINUE   
  481. X         IF(LMODUS(ICL1)) THEN  
  482. XC Module start  
  483. X            IF(LCHECK(39).AND.IOSE+IOSO+IOSS+IOSD+IOSP.NE.0) THEN   
  484. X               WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI)
  485. X            ENDIF   
  486. X            IOSM = 1
  487. X         ELSE IF(LDECLR(ICL1)) THEN 
  488. XC PARAMETER etc 
  489. X            IF(LCHECK(39).AND.IOSD+IOSS+IOSO+IOSE.NE.0) THEN
  490. X               WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI)
  491. X               NGLOBF = NGLOBF + 1  
  492. X            ENDIF   
  493. X            IOSP = 1
  494. X         ELSE IF(LDATA(ICL1)) THEN  
  495. XC DATA Statement
  496. X            IF(LCHECK(39).AND.IOSS+IOSO+IOSE.NE.0) THEN 
  497. X               WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI)
  498. X               NGLOBF = NGLOBF + 1  
  499. X            ENDIF   
  500. X            IOSD = 1
  501. X         ELSE IF(ICL1.EQ.IEND) THEN 
  502. XC END Statement 
  503. X            IOSE = 1
  504. X         ELSE IF(LASIGN(ICL1)) THEN 
  505. XC Possible statement function   
  506. X            IFOUN = 0   
  507. X            DO 270 IN=1,NRNAME  
  508. X               IF(.NOT.BTEST(NAMTYP(IRNAME+IN),9))              GOTO 270
  509. X               CNAM = SNAMES(IRNAME+IN) 
  510. X               ILEN = INDEX(CNAM,' ')-1 
  511. X               IF(ILEN.EQ.-1) ILEN = MXNMCH 
  512. XC Search for the statement function name at the left of 
  513. XC an '=' sign . Simple approach but probably not rigorous . 
  514. X               IND = INDEX(SIMA(NST),CNAM(:ILEN))   
  515. XC   
  516. XC CONFIRM THAT THIS IS THE FIRST NAME ON THE LINE   
  517. XC   
  518. X               DO 259 ICHP=7,IND-1  
  519. X                  IF(SIMA(NST)(ICHP:ICHP).NE.' ') GOTO 270  
  520. X  259          CONTINUE 
  521. X               INDE = INDEX(SIMA(NST),'=')  
  522. X               IF(INDE.LT.IND)                                  GOTO 270
  523. X               IF(IND.EQ.0)                                     GOTO 270
  524. X               DO 260 ILOC=IND+ILEN,MXLINE  
  525. X                  IF(SIMA(NST)(ILOC:ILOC).EQ.' ')               GOTO 260
  526. X                  IF(SIMA(NST)(ILOC:ILOC).EQ.'=') THEN  
  527. X                     IFOUN = 1  
  528. X                     CNAMF = CNAM   
  529. X                                                                GOTO 280
  530. X                  ELSE IF(SIMA(NST)(ILOC:ILOC).EQ.'(') THEN 
  531. X                     NP = 0 
  532. X                     IF(NUMP.GE.MNUMP) THEN 
  533. X                        WRITE(MZUNIT,520)   
  534. X                                                                GOTO 280
  535. X                     ENDIF  
  536. X                     NUMP = NUMP + 1
  537. X                                                                GOTO 260
  538. X                  ENDIF 
  539. X                  IF(SIMA(NST)(ILOC:ILOC).GE.'A'.AND. SIMA(NST) 
  540. X     +            (ILOC:ILOC) .LE.'Z') THEN 
  541. X                     NP = NP + 1
  542. X                     IF(NP.GT.MXNMCH)                           GOTO 260
  543. X                     CNAMP(NUMP)(NP:NP) = SIMA(NST)(ILOC:ILOC)  
  544. X                  ENDIF 
  545. X                  IF(SIMA(NST)(ILOC:ILOC).EQ.',') THEN  
  546. X                     NP = 0 
  547. X                     IF(NUMP.GE.MNUMP) THEN 
  548. X                        WRITE(MZUNIT,520)   
  549. X                                                                GOTO 280
  550. X                     ENDIF  
  551. X                     NUMP = NUMP + 1
  552. X                  ENDIF 
  553. X  260          CONTINUE 
  554. X  270       CONTINUE
  555. X  280       CONTINUE
  556. X            IF(IFOUN.EQ.1) THEN 
  557. X               NUMF = NUMF + 1  
  558. XC Check that statement function surrounded by comment cards 
  559. X               IF(NSTFUN.EQ.0) THEN 
  560. X                  NSTFUN = NST  
  561. X                  IF(LCHECK(40)) THEN   
  562. X                     IF(SIMA(NST-1)(1:1).NE.'C'.AND.SIMA(NST-1)(1:1).NE.
  563. X     +               '*') THEN  
  564. X                        WRITE(MZUNIT,530) CNAMF 
  565. X                        NGLOBF = NGLOBF + 1 
  566. X                     ENDIF  
  567. X                  ENDIF 
  568. X               ENDIF
  569. X               NSTFIN = NFI+1   
  570. X               IOSS = 1 
  571. X               IF(LCHECK(39).AND.IOSO+IOSE.NE.0) THEN   
  572. X                  WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI) 
  573. X                  NGLOBF = NGLOBF + 1   
  574. X               ENDIF
  575. X            ELSE
  576. XC OTHER Statement   
  577. X               IF(LCHECK(39).AND.IOSE.EQ.1) THEN
  578. X                  WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI) 
  579. X                  NGLOBF = NGLOBF + 1   
  580. X               ENDIF
  581. X               IOSO = 1 
  582. X            ENDIF   
  583. XC Single occurences of names forced here
  584. X            DO 300 II=1,NUMP-1  
  585. X               CNAM=CNAMP(II)   
  586. X               DO 290 IJ=II+1,NUMP  
  587. X                  IF(CNAM.EQ.CNAMP(IJ)) ICNAMP(IJ)=ICNAMP(II)   
  588. X  290          CONTINUE 
  589. X  300       CONTINUE
  590. XC Check that statement function variables are not used elsewhere
  591. X            IF(IFOUN.EQ.0) THEN 
  592. X               DO 320 ISN=1,NSNAME  
  593. X                  CNAM = SNAMES(ISNAME+ISN) 
  594. X                  DO 310 ISN2=1,NUMP
  595. X                     IF(CNAM.EQ.CNAMP(ISN2)) THEN   
  596. X                        IF(LCHECK(41).AND.ICNAMP(ISN2).EQ.0) THEN   
  597. X                           WRITE(MZUNIT,540) CNAM   
  598. X                           NGLOBF = NGLOBF + 1  
  599. X                        ENDIF   
  600. X                        ICNAMP(ISN2) = 1
  601. X                                                                GOTO 320
  602. X                     ENDIF  
  603. X  310             CONTINUE  
  604. X  320          CONTINUE 
  605. X            ENDIF   
  606. X         ENDIF  
  607. X  330 CONTINUE  
  608. X      IF(LCHECK(40)) THEN   
  609. X         IF(NUMF.GT.1.AND.SIMA(NSTFIN)(1:1).NE.'C'.AND. SIMA(NSTFIN)
  610. X     +   (1:1) .NE.'*') THEN
  611. X            WRITE(MZUNIT,530) CNAMF 
  612. X            NGLOBF = NGLOBF + 1 
  613. X         ENDIF  
  614. X      ENDIF 
  615. X      RETURN
  616. X  500 FORMAT(1X,'!!! WARNING ... ARGUMENT ',A,' PASSED TO THIS ',   
  617. X     +'MODULE, IS NOT CHARACTER*(*)')   
  618. X  510 FORMAT(1X,'!!! WARNING ... ARGUMENT ',A,' PASSED TO THIS ',   
  619. X     +'MODULE, DOES NOT HAVE LAST DIMENSION "*"')   
  620. X  520 FORMAT(1X,'!!! NON-FATAL ERROR IN SECPAS . MNUMP EXCEEDED')   
  621. X  530 FORMAT(1X,'!!! WARNING ... STATEMENT FUNCTION ',A,' IS NOT',  
  622. X     +' SURROUNDED BY COMMENTS')
  623. X  540 FORMAT(1X,'!!! WARNING ... VARIABLE ',A,  
  624. X     +',IN STATEMENT FUNCTION DEFINITION, IS USED ELSEWHERE')   
  625. X  550 FORMAT(1X,'!!! WARNING ... FOLLOWING STATEMENT IS',   
  626. X     +' OUT OF ORDER ',(/,1X,A80))  
  627. X      END   
  628. /
  629. echo 'x - USSBEG.f'
  630. sed 's/^X//' > USSBEG.f << '/'
  631. X      SUBROUTINE USSBEG 
  632. X*-----------------------------------------------------------------------
  633. X*   
  634. X*--- user start of filtered statement (treat names here)
  635. X*   
  636. X*-----------------------------------------------------------------------
  637. X      include 'PARAM.h' 
  638. X      include 'ALCAZA.h' 
  639. X      include 'CLASS.h' 
  640. X      include 'CURSTA.h' 
  641. X      include 'FLWORK.h' 
  642. X      include 'KEYCOM.h' 
  643. X      include 'TYPDEF.h' 
  644. X      include 'JOBSUM.h' 
  645. X      include 'STATE.h' 
  646. X      include 'FLAGS.h' 
  647. X      include 'USCOMN.h' 
  648. X      include 'USSTMT.h' 
  649. X      include 'USIGNO.h' 
  650. X      include 'USLIST.h' 
  651. X      include 'USUNIT.h' 
  652. X      include 'USARGS.h' 
  653. X      include 'USINFN.h' 
  654. X      include 'USLTYD.h' 
  655. X      include 'CHECKS.h' 
  656. X      CHARACTER*(MXNMCH) CNAM   
  657. X      CHARACTER*25 C25NAM   
  658. X      LOGICAL FOK   
  659. X      DATA ICALL /0/
  660. X      IF(UNFLP) RETURN  
  661. X      IF(ICALL.EQ.0) THEN   
  662. X         ISGLOB = 0 
  663. X         ICALL = 1  
  664. X      ENDIF 
  665. XC Determine whether this module is to be processed  
  666. X      IF(.NOT.RPROCS) RETURN
  667. X      NST = NFLINE(NSTREF)  
  668. X      NFI = NLLINE(NSTREF)  
  669. X      ICL1 = ICURCL(1)  
  670. X      ICL2 = ICURCL(2)  
  671. XC ICL1 is class of first part of statement  
  672. XC ICL2 is class of second part if ICL1 is an IF statement   
  673. X      IF(LMODUS(ICL1)) THEN 
  674. XC Module start  
  675. XC   
  676. X         IF(NIGNOS.NE.0) THEN   
  677. X            CNAM = SNAMES(ISNAME+1) 
  678. X            ILEN = INDEX(CNAM,' ')-1
  679. X            IF(ILEN.EQ.-1) ILEN = MXNMCH
  680. X            DO 10 IGN=1,NIGNOS  
  681. X               IF(LIGNOS(IGN).NE.ILEN)                           GOTO 10
  682. X               IF(CIGNOS(IGN).EQ.CNAM) THEN 
  683. X                  NFAULT = 0
  684. X                  RPROCS = .FALSE.  
  685. X                  RETURN
  686. X               ENDIF
  687. X   10       CONTINUE
  688. X         ENDIF  
  689. X         WRITE(MZUNIT,550) (SIMA(II)(7:),II=NST,NFI)
  690. X         ISTMT = 0  
  691. X         NCOMN = 0  
  692. X         NCOMT = 0  
  693. X         IFUNC = 0  
  694. XC Set FUNCTION flag 
  695. X         IF(LFUNCT(ICL1)) IFUNC = 1 
  696. X         ICLOLD = ICL1  
  697. X         NFIOLD = NFI   
  698. X         IF(LCHECK(11).AND.NSTREF.NE.1) WRITE(MZUNIT,560)   
  699. XC Make check for module names the same as intrinsic functions   
  700. X         CNAM = SNAMES(ISNAME+1)
  701. X         ILEN = INDEX(CNAM,' ')-1   
  702. X         IF(LCHECK(12)) THEN
  703. X            DO 20 I=1,LIF   
  704. X               IF(ILEN.NE.INDEX(CINFUN(I),' ')-1)                GOTO 20
  705. X               IF(CNAM(:ILEN).NE.CINFUN(I)(:ILEN))               GOTO 20
  706. X               WRITE(MZUNIT,570) CNAM,CNAM  
  707. X               NFAULT = NFAULT + 1  
  708. X                                                                 GOTO 30
  709. X   20       CONTINUE
  710. X   30       CONTINUE
  711. X         ENDIF  
  712. XC First statement in input should be module declaration 
  713. X      ELSE IF(LCHECK(13).AND.ISGLOB.EQ.0.AND.NFIOLD.EQ.0) THEN  
  714. X         WRITE(MZUNIT,500)  
  715. X         NFAULT = NFAULT + 1
  716. X      ENDIF 
  717. XC Make check for comment lines after start of routine   
  718. X      ISTMT=ISTMT+1 
  719. X      IF(LCHECK(14).AND.ISTMT.EQ.2) THEN
  720. X         IF(NST-NFIOLD.LT.3) THEN   
  721. X            WRITE(MZUNIT,580)   
  722. X            NFAULT = NFAULT + 1 
  723. X         ENDIF  
  724. X      ENDIF 
  725. X      IF(NST-NFIOLD.GT.1) THEN  
  726. X         IF(USFULL) WRITE(MZUNIT,510) (II+ISGLOB,SIMA(II), II=NFIOLD+1, 
  727. X     +   NST-1) 
  728. XC Check comment lines   
  729. X         ICMSET = 0 
  730. X         DO 40 I=NFIOLD+1,NST-1 
  731. X            IF(NLTYPE(I).EQ.0) THEN 
  732. XC Store comment line if TREE option requested   
  733. X               IF(ACTION(29).AND.SIMA(I)(1:2).EQ.'C!') THEN 
  734. X                  IF(ICMSET.EQ.0) CMMNT = SIMA(I)(3:LARC+2) 
  735. X                  ICMSET = 1
  736. X               ENDIF
  737. XC comment lines should start with C 
  738. X               IF(LCHECK(15).AND.SIMA(I)(1:1).NE.'C') THEN  
  739. X                  IF(.NOT.USFULL) WRITE(MZUNIT,510) I+ISGLOB,SIMA(I)
  740. X                  WRITE(MZUNIT,590) 
  741. X                  NFAULT = NFAULT + 1   
  742. X               ENDIF
  743. X            ENDIF   
  744. X   40    CONTINUE   
  745. X      ENDIF 
  746. X      NFIOLD = NFI  
  747. XC Write all statements to MZUNIT if USFULL set  
  748. X      IF(USFULL) THEN   
  749. X        WRITE(MZUNIT,510) (II+ISGLOB,SIMA(II),II=NST,NFI)   
  750. X      ENDIF 
  751. XC   
  752. XC Check for comment lines in between continuations  
  753. X      IF(LCHECK(16).AND.NFI-NST.GT.0) THEN  
  754. X         DO 50 IST=NST+1,NFI-1  
  755. X            IF(SIMA(IST)(:5).NE.'      ') THEN  
  756. X               IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II 
  757. X     +         =NST,NFI)
  758. X               WRITE(MZUNIT,610)
  759. X               NFAULT = NFAULT + 1  
  760. X                                                                 GOTO 60
  761. X            ENDIF   
  762. X   50    CONTINUE   
  763. X   60    CONTINUE   
  764. X      ENDIF 
  765. XC Check for standard variable types 
  766. X      IF(LCHECK(17).AND.LNSVT(ICL1)) THEN   
  767. X         IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II=NST,  
  768. X     +   NFI)   
  769. X         WRITE(MZUNIT,520)  
  770. X         NFAULT = NFAULT + 1
  771. X      ENDIF 
  772. XC Collect list of COMMON names used in this routine 
  773. X      IF(LCOMMN(ICL1)) THEN 
  774. XC First check that only one COMMON name per COMMON statement
  775. X         IPOS1 = INDEX(SSTA(:NCHST),'/')
  776. X         IF(IPOS1.EQ.0) GOTO 70 
  777. X         IPOS2 = INDEX(SSTA(IPOS1+1:NCHST),'/') 
  778. X         IF(IPOS2.EQ.0) GOTO 70 
  779. X         IPOS3 = INDEX(SSTA(IPOS1+IPOS2+1:NCHST),'/')   
  780. X         IF(IPOS3.NE.0) THEN
  781. X            IF(.NOT.USFULL) WRITE(MZUNIT,850)   
  782. X     &                   (II+ISGLOB,SIMA(II),II =NST,NFI)   
  783. X            WRITE(MZUNIT,620)   
  784. X            NFAULT = NFAULT + 1 
  785. X         ENDIF  
  786. X   70    CONTINUE   
  787. X         NCOMT = NCOMT + 1  
  788. X         IF(NCOMT.GT.MCOMT) THEN
  789. X            NCOMT = NCOMT-1 
  790. X            WRITE(MZUNIT,630)   
  791. X                                                                GOTO 110
  792. X         ENDIF  
  793. XC Take account of blank COMMON  
  794. X         IF(INDEX(SSTA(:NCHST),'//').NE.0.OR.   
  795. X     &      INDEX(SSTA(:NCHST),'/ /').NE.0) THEN
  796. X            SCTITL(NCOMT) = 'BLANKCOM'  
  797. X            IST = 1 
  798. X         ELSE   
  799. X            SCTITL(NCOMT) = SNAMES(ISNAME+1)
  800. X            IST = 2 
  801. X         ENDIF  
  802. X         ICTITL(NCOMT) = NCOMN + 1  
  803. X         DO 100 ISN=IST,NSNAME  
  804. XC We ensure that the list of names for this COMMON block does not   
  805. XC include parameters. This is done by checking for no hanging parentheses.  
  806. X            IBEG = NSSTRT(ISN)  
  807. X            ICOUNB = 0  
  808. X            DO 95 ICH=1,IBEG-1  
  809. X               IF(SSTA(ICH:ICH).EQ.'(') THEN
  810. X                 ICOUNB=ICOUNB+1
  811. X               ELSE IF(SSTA(ICH:ICH).EQ.')') THEN   
  812. X                 ICOUNB=ICOUNB-1
  813. X               ENDIF
  814. X   95       CONTINUE
  815. X            IF(ICOUNB.NE.0) GOTO 100
  816. X            NCOMN = NCOMN + 1   
  817. X            IF(NCOMN.GT.MCOMN) THEN 
  818. X               NCOMN = NCOMN-1  
  819. X               WRITE(MZUNIT,640)
  820. X                                                                GOTO 110
  821. X            ENDIF   
  822. X            SCNAME(NCOMN) = SNAMES(ISNAME+ISN)  
  823. X            ICNAME(NCOMN) = NCOMT   
  824. X  100    CONTINUE   
  825. X  110    CONTINUE   
  826. X      ENDIF 
  827. XC Check for statements which dimension outside COMMON   
  828. X      IF(LCHECK(19).AND.LDIMEN(ICL1)) THEN  
  829. X         IOVER = 0  
  830. X         DO 150 I=1,NSNAME  
  831. X            CNAM = SNAMES(I+ISNAME) 
  832. X            ILEN = INDEX(CNAM,' ')-1
  833. X            IF(ILEN.EQ.-1)                                      GOTO 150
  834. X            MATCH = 0   
  835. X            DO 130 IC=1,NCOMN   
  836. X               ILEN1 = INDEX(SCNAME(IC),' ')-1  
  837. X               IF(ILEN1.NE.ILEN)                                GOTO 130
  838. X               IF(CNAM.NE.SCNAME(IC))                           GOTO 130
  839. X               MATCH = 1
  840. XC Now have found a declaration of a name in COMMON  
  841. XC Search for position of name in the statement  
  842. X               INDE = NSEND(I)+1
  843. XC Search for ( or , and ignore blanks   
  844. X               DO 120 IPL = INDE,NCHST  
  845. X                  IF(SSTA(IPL:IPL).EQ.' ')                      GOTO 120
  846. X                  IF(SSTA(IPL:IPL).EQ.',')                      GOTO 140
  847. X                  IF(SSTA(IPL:IPL).EQ.'(') THEN 
  848. XC array declaration 
  849. X                     IF(IOVER.EQ.0.AND..NOT.USFULL) WRITE(MZUNIT,850)   
  850. X     +               (II+ ISGLOB, SIMA(II),II=NST,NFI)  
  851. X                     WRITE(MZUNIT,650) CNAM 
  852. X                     NFAULT = NFAULT + 1
  853. X                     IOVER = 1  
  854. X                                                                GOTO 150
  855. X                  ELSE  
  856. X                                                                GOTO 140
  857. X                  ENDIF 
  858. X  120          CONTINUE 
  859. X  130       CONTINUE
  860. X  140       CONTINUE
  861. X  150    CONTINUE   
  862. X      ENDIF 
  863. XC Check for embedded blanks in names
  864. X      IF(LCHECK(20)) THEN   
  865. X         IDONE = 0  
  866. X         DO 160 I=1,NSNAME  
  867. X            CNAM=SNAMES(I+ISNAME)   
  868. X            ILEN1 = INDEX(CNAM,' ')-1   
  869. X            IF(ILEN1.EQ.-1) ILEN1 = MXNMCH  
  870. X            IF(ILEN1.GT.6)                                      GOTO 160
  871. X            NS = NSSTRT(I)  
  872. X            NE = NSEND(I)   
  873. X            ILEN2 = NE-NS+1 
  874. X            IF(ILEN2.NE.ILEN1) THEN 
  875. X               IF(IDONE.EQ.0.AND..NOT.USFULL) WRITE(MZUNIT,850) (II 
  876. X     +         +ISGLOB, SIMA(II),II=NST, NFI)   
  877. X               WRITE(MZUNIT,660) CNAM   
  878. X               IDONE = 1
  879. X               NFAULT = NFAULT + 1  
  880. X            ENDIF   
  881. X  160    CONTINUE   
  882. X      ENDIF 
  883. XC Now check for embedded blanks in  syntactic entities  
  884. X      NF1 = ISTMDS(3,ICL1)  
  885. X      NL1 = ISTMDS(4,ICL1)  
  886. X      IF(LIFF(ICL1)) THEN   
  887. X         NF2 = ISTMDS(3,ICL2)   
  888. X         NL2 = ISTMDS(4,ICL2)   
  889. X      ELSE  
  890. X         NF2 = 0
  891. X      ENDIF 
  892. X      IF(LCHECK(21)) THEN   
  893. XC DEFSTA returns FOK=.TRUE. if statement ICL1 is to be checked  
  894. X         CALL DEFSTA(ICL1,ILEN,C25NAM,FOK)  
  895. X         IF(FOK) THEN   
  896. X            INDE = INDEX(SIMA(NST),C25NAM(:ILEN))   
  897. X            IF(INDE.EQ.0) THEN  
  898. X               IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II 
  899. X     +         =NST, NFI)   
  900. X               WRITE(MZUNIT,670) C25NAM 
  901. X               NFAULT = NFAULT + 1  
  902. X            ELSE
  903. X               IF(SIMA(NST)(INDE+ILEN:INDE+ILEN).NE.' ') THEN   
  904. X                  IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),
  905. X     +            II =NST,NFI)  
  906. X                  WRITE(MZUNIT,680) C25NAM  
  907. X                  NFAULT = NFAULT + 1   
  908. X               ENDIF
  909. X            ENDIF   
  910. X         ENDIF  
  911. XC Special treatment of GO TO and ELSE IF
  912. X         IF(LELSE(ICL1)) THEN   
  913. X            INDE = INDEX(SSTA(:NCHST),'ELSE')   
  914. X            IF(INDE.EQ.0) THEN  
  915. X               IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II), II
  916. X     +         =NST,NFI)
  917. X               WRITE(MZUNIT,690)
  918. X               NFAULT = NFAULT + 1  
  919. X            ELSE
  920. X               IBL = 0  
  921. X               DO 170 ICH=INDE+4,NCHST  
  922. X                  IF(SSTA(ICH:ICH).EQ.' ') THEN 
  923. X                     IBL=IBL+1  
  924. X                                                                GOTO 170
  925. X                  ELSE IF(SSTA(ICH:ICH+1).EQ.'IF') THEN 
  926. X                     IF(IBL.GT.1) THEN  
  927. X                        IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,   
  928. X     +                  SIMA(II), II=NST,NFI)   
  929. X                        WRITE(MZUNIT,690)   
  930. X                                                                GOTO 180
  931. XC             ELSE IF(SSTA(ICH+2:ICH+2).NE.' ') THEN
  932. XC               IF(.NOT.USFULL) WRITE(MZUNIT,685) (II+ISGLOB,SIMA(II),  
  933. XC    &          II=NST,NFI) 
  934. XC               WRITE(MZUNIT,610)   
  935. XC               GOTO 334
  936. X                     ENDIF  
  937. X                  ENDIF 
  938. X                                                                GOTO 180
  939. X  170          CONTINUE 
  940. X  180          CONTINUE 
  941. X            ENDIF   
  942. X         ENDIF  
  943. X         IF(LGOTO(ICL1)) THEN   
  944. X            INDE = 0
  945. X            INDE1 = INDEX(SSTA(:NCHST),'GO TO') 
  946. X            IF(INDE1.EQ.0) INDE = INDEX(SSTA(:NCHST),'GOTO')
  947. X            IF(INDE.EQ.0.AND.INDE1.EQ.0) THEN   
  948. X               IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II 
  949. X     +         =NST, NFI)   
  950. X               WRITE(MZUNIT,710)
  951. X               NFAULT = NFAULT + 1  
  952. X            ELSE IF(INDE1.NE.0.AND.INDEX(SSTA(:NCHST),'GO TO ').EQ.0)   
  953. X     +         THEN 
  954. X               IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II 
  955. X     +         =NST, NFI)   
  956. X               WRITE(MZUNIT,720)
  957. X               NFAULT = NFAULT + 1  
  958. X            ELSE IF(INDE.NE.0.AND.INDEX(SSTA(:NCHST),'GOTO ').EQ.0) 
  959. X     +         THEN 
  960. X               IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II 
  961. X     +         =NST, NFI)   
  962. X               WRITE(MZUNIT,730)
  963. X               NFAULT = NFAULT + 1  
  964. X            ENDIF   
  965. X         ENDIF  
  966. XC End special treatment for ICL1
  967. X         IF(NF2.NE.0) THEN  
  968. X            CALL DEFSTA(ICL2,ILEN,C25NAM,FOK)   
  969. X            IF(FOK) THEN
  970. X               DO 190 IJ=NST,NFI
  971. X                  INDE = INDEX(SIMA(IJ),C25NAM(:ILEN))  
  972. X                  IF(INDE.NE.0) THEN
  973. X                     IF(SIMA(IJ)(INDE+ILEN:INDE+ILEN).NE.' ') THEN  
  974. X                        IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,   
  975. X     +                  SIMA(II),II =NST,NFI)   
  976. X                        WRITE(MZUNIT,680) C25NAM
  977. X                        NFAULT = NFAULT + 1 
  978. X                     ENDIF  
  979. X                                                                GOTO 200
  980. X                  ENDIF 
  981. X  190          CONTINUE 
  982. X               IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II 
  983. X     +         =NST, NFI)   
  984. X               WRITE(MZUNIT,670) C25NAM 
  985. X               NFAULT = NFAULT + 1  
  986. X  200          CONTINUE 
  987. X            ENDIF   
  988. X         ENDIF  
  989. XC Special treatment of GO TO after IF statement 
  990. X         IF(LGOTO(ICL2).AND.NF2.NE.0) THEN  
  991. X            DO 210 IJ=NST,NFI   
  992. X               INDE = 0 
  993. X               INDE1 = INDEX(SIMA(IJ),'GO TO')  
  994. X               IF(INDE1.EQ.0) INDE = INDEX(SIMA(IJ),'GOTO') 
  995. X               IF(INDE.NE.0) THEN   
  996. X                  IF(INDEX(SIMA(IJ),'GOTO ').EQ.0) THEN 
  997. X                     IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA  
  998. X     +               (II),II =NST,NFI)  
  999. X                     WRITE(MZUNIT,740)  
  1000. X                     NFAULT = NFAULT + 1
  1001. X                  ENDIF 
  1002. X                                                                GOTO 220
  1003. X               ELSE IF(INDE1.NE.0) THEN 
  1004. X                  IF(INDEX(SIMA(IJ),'GO TO ').EQ.0) THEN
  1005. X                     IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA  
  1006. X     +               (II),II =NST,NFI)  
  1007. X                     WRITE(MZUNIT,750)  
  1008. X                     NFAULT = NFAULT + 1
  1009. X                  ENDIF 
  1010. X                                                                GOTO 220
  1011. X               ELSE IF(IJ.EQ.NFI) THEN  
  1012. X                  IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),
  1013. X     +            II =NST,NFI)  
  1014. X                  WRITE(MZUNIT,760) 
  1015. X                  NFAULT = NFAULT + 1   
  1016. X                                                                GOTO 220
  1017. X               ENDIF
  1018. X  210       CONTINUE
  1019. X  220       CONTINUE
  1020. X         ENDIF  
  1021. X      ENDIF 
  1022. XC End special treatment for ICL2 GOTO   
  1023. X      IF(LCHECK(22).AND.(LPRINT(ICL1).OR.LPRINT(ICL2))) THEN
  1024. XC PRINT statement   
  1025. X         IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II=NST,  
  1026. X     +   NFI)   
  1027. X         WRITE(MZUNIT,770)  
  1028. X         NFAULT = NFAULT + 1
  1029. X      ELSE IF(LCHECK(23).AND.ICL1.EQ.IEND) THEN 
  1030. XC END statement 
  1031. X         IF(SIMA(NST)(:5).NE.'     ') THEN  
  1032. X            IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II
  1033. X     +      =NST, NFI)  
  1034. X            WRITE(MZUNIT,790)   
  1035. X            NFAULT = NFAULT + 1 
  1036. X         ENDIF  
  1037. X      ELSE IF(LWRITE(ICL1).OR.LWRITE(ICL2)) THEN
  1038. XC WRITE statement   
  1039. X         IF(LCHECK(24)) THEN
  1040. X            ILOC = INDEX(SSTA(:NCHST),'WRITE')+5
  1041. X            ILOC1 = INDEX(SSTA(ILOC:NCHST),'(') 
  1042. X            IF(ILOC1.EQ.0.OR.ILOC.EQ.0)                         GOTO 240
  1043. X            ILOC = ILOC1 + ILOC 
  1044. X            DO 230 IL=ILOC,MXLINE   
  1045. X               IF(SSTA(IL:IL).EQ.' ')                           GOTO 230
  1046. X               IF(SSTA(IL:IL).EQ.'*') THEN  
  1047. X                  IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),
  1048. X     +            II =NST,NFI)  
  1049. X                  WRITE(MZUNIT,800) 
  1050. X                  NFAULT = NFAULT + 1   
  1051. X               ELSE 
  1052. X                                                                GOTO 240
  1053. X               ENDIF
  1054. X  230       CONTINUE
  1055. X  240       CONTINUE
  1056. X         ENDIF  
  1057. X      ENDIF 
  1058. X      IF(LCHECK(26).AND.(LPAUSE(ICL1).OR.LPAUSE(ICL2))) THEN
  1059. XC PAUSE statement   
  1060. X         IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II=NST,  
  1061. X     +   NFI)   
  1062. X         WRITE(MZUNIT,810)  
  1063. X         NFAULT = NFAULT + 1
  1064. X      ENDIF 
  1065. XC check for statement labels beginning in column 1  
  1066. X      IF(LCHECK(27)) THEN   
  1067. X         IF(LLE(SIMA(NST)(1:1),'9').AND.LGE(SIMA(NST)(1:1),'0')) THEN   
  1068. X            IF(.NOT.USFULL)WRITE(MZUNIT,850)(II+ISGLOB,SIMA(II),II=NST, 
  1069. X     +      NFI)
  1070. X            WRITE(MZUNIT,530)   
  1071. X            NFAULT = NFAULT + 1 
  1072. X         ENDIF  
  1073. X      ENDIF 
  1074. X      IF(LCHECK(28).AND.(LSTOP(ICL1).OR.LSTOP(ICL2))) THEN  
  1075. XC STOP statement
  1076. X         IF(.NOT.LWRITE(ICLOLD)) THEN   
  1077. X            IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II
  1078. X     +      =NST, NFI)  
  1079. X            WRITE(MZUNIT,820)   
  1080. X            NFAULT = NFAULT + 1 
  1081. X         ENDIF  
  1082. X      ENDIF 
  1083. XC Check for ENTRY in FUNCTION   
  1084. X      IF(LCHECK(29).AND.LENTRY(ICL1).AND.IFUNC.EQ.1) THEN   
  1085. X         IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II=NST,  
  1086. X     +   NFI)   
  1087. X         WRITE(MZUNIT,830)  
  1088. X         NFAULT = NFAULT + 1
  1089. X      ENDIF 
  1090. XC Check for I/O in FUNCTION 
  1091. X      IF(LCHECK(30).AND.IFUNC.EQ.1) THEN
  1092. X         IF(LIO(ICL1)) THEN 
  1093. X            IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II
  1094. X     +      =NST,NFI)   
  1095. X            WRITE(MZUNIT,780)   
  1096. X            NFAULT = NFAULT + 1 
  1097. X         ENDIF  
  1098. X         IF(LIO(ICL2)) THEN 
  1099. X            IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II
  1100. X     +      =NST,NFI)   
  1101. X            WRITE(MZUNIT,780)   
  1102. X            NFAULT = NFAULT + 1 
  1103. X         ENDIF  
  1104. X      ENDIF 
  1105. XC check for alternate RETURN
  1106. X      IF(LCHECK(31).AND.(LRETRN(ICL1).OR.LRETRN(ICL2))) THEN
  1107. X         IPOSR=INDEX(SSTA(:NCHST),'RETURN') 
  1108. X         IF(IPOSR.NE.0.AND.IPOSR+5.NE.NCHST) THEN   
  1109. X            IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB, SIMA(II),II   
  1110. X     +      =NST, NFI)  
  1111. X            WRITE(MZUNIT,540)   
  1112. X            NFAULT = NFAULT + 1 
  1113. X         ENDIF  
  1114. X      ENDIF 
  1115. XC Check for COMMON block title clash with variable name 
  1116. X      IF(.NOT.LCOMMN(ICL1).AND..NOT.LSAVE(ICL1)) THEN   
  1117. X         DO 280 IS=1,NSNAME 
  1118. X            ILEN = INDEX(SNAMES(IS+ISNAME),' ')-1   
  1119. X            DO 250 ICT=1,NCOMT  
  1120. X               ILEN2 = INDEX(SCTITL(ICT),' ')-1 
  1121. X               IF(ILEN2.NE.ILEN)                                GOTO 250
  1122. X               IF(LCHECK(32)) THEN  
  1123. X                  IF(SNAMES(IS+ISNAME).EQ.SCTITL(ICT)) THEN 
  1124. X                     IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA  
  1125. X     +               (II),II =NST,NFI)  
  1126. X                     WRITE(MZUNIT,840) SCTITL(ICT),SCTITL(ICT)  
  1127. X                     NFAULT = NFAULT + 1
  1128. X                                                                GOTO 260
  1129. X                  ENDIF 
  1130. X               ENDIF
  1131. X  250       CONTINUE
  1132. X  260       CONTINUE
  1133. XC Mark COMMON block variables as used   
  1134. X            DO 270 ICN=1,NCOMN  
  1135. X               ILEN2 = INDEX(SCNAME(ICN),' ')-1 
  1136. X               IF(ILEN2.NE.ILEN)                                GOTO 270
  1137. X               IF(SCNAME(ICN).EQ.SNAMES(IS+ISNAME)) THEN
  1138. X                  ICM = ICNAME(ICN) 
  1139. X                  ICTITL(ICM) = -IABS(ICTITL(ICM))  
  1140. X               ENDIF
  1141. X  270       CONTINUE
  1142. X  280    CONTINUE   
  1143. X      ENDIF 
  1144. XC Make ICLOLD last executable statement 
  1145. X      IF(ISTMDS(11,ICL1).EQ.1) THEN 
  1146. X         ICLOLD = ICL2  
  1147. X         IF(ICL1.NE.IIF) ICLOLD = ICL1  
  1148. X      ENDIF 
  1149. XC   
  1150. X  500 FORMAT(/,1X,'!!! WARNING ... INPUT FORTRAN SHOULD BEGIN', 
  1151. X     +' WITH MODULE DECLARATION EG "PROGRAM  ... "')
  1152. X  510 FORMAT((1X,I6,'. ',A80))  
  1153. X  520 FORMAT(1X,'!!! WARNING ... USE STANDARD FORTRAN TYPES')   
  1154. X  530 FORMAT(1X,'!!! STATEMENT HAS LABEL BEGINNING IN COLUMN 1')
  1155. X  540 FORMAT(1X,'!!! STATEMENT USES THE ALTERNATE RETURN FACILITY') 
  1156. X  550 FORMAT(/,1X,20('+'), ' BEGIN MODULE CHECKS          ',10('+'), /, 
  1157. X     +21X,' FOR ',A80,(/,1X,A80))   
  1158. X  560 FORMAT(1X,'!!! WARNING ... AVOID COMMENT LINES',  
  1159. X     +' BEFORE MODULE DECLARATION') 
  1160. X  570 FORMAT(1X,'!!! WARNING ... MODULE ',A,
  1161. X     +' CLASHES WITH INTRINSIC FUNCTION ',A)
  1162. X  580 FORMAT(1X,'!!! WARNING ... NOT ENOUGH (<3) COMMENT',  
  1163. X     +' LINES AT START OF MODULE')  
  1164. X  590 FORMAT(1X,'!!! COMMENT DOES NOT START WITH "C"')  
  1165. X  600 FORMAT(1X,'    IT SHOULD BE A HISTORIAN "CALL" ANYWAY')   
  1166. X  610 FORMAT(1X,'!!! STATEMENT HAS COMMENT PLACED BEFORE CONTINUATION') 
  1167. X  620 FORMAT(1X,'!!! STATEMENT CONTAINS >1 COMMON DEFINITION')  
  1168. X  630 FORMAT(1X,'!!! NON-FATAL ERROR IN USSBEG . MCOMT EXCEEDED')   
  1169. X  640 FORMAT(1X,'!!! NON-FATAL ERROR IN USSBEG . MCOMN EXCEEDED')   
  1170. X  650 FORMAT(1X,'!!! STATEMENT DIMENSIONS ',A,' OUTSIDE COMMON')
  1171. X  660 FORMAT(1X,'!!! NAME ',A,' HAS EMBEDDED BLANKS AT SOURCE') 
  1172. X  670 FORMAT(1X,'!!! THE KEYWORD ',A,' CONTAINS BLANKS')
  1173. X  680 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER KEYWORD ',A25)
  1174. X  690 FORMAT(1X,'!!! KEYWORD "ELSE IF" CONTAINS MISPLACED BLANKS')  
  1175. X  700 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "ELSEIF"')
  1176. X  710 FORMAT(1X,'!!! KEYWORD "GO TO" CONTAINS MISPLACED BLANKS')
  1177. X  720 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "GO TO"') 
  1178. X  730 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "GOTO"')  
  1179. X  740 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "GOTO"')  
  1180. X  750 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "GO TO"') 
  1181. X  760 FORMAT(1X,'!!! STATEMENT CONTAINS EMBEDDED BLANKS IN "GO TO"')
  1182. X  770 FORMAT(1X,'!!! STATEMENT SHOULD BE A WRITE STATEMENT')
  1183. X  780 FORMAT(1X,'!!! I/O IN FUNCTIONS DISALLOWED')  
  1184. X  790 FORMAT(1X,'!!! STATEMENT SHOULD NOT HAVE LABEL')  
  1185. X  800 FORMAT(1X,'!!! STATEMENT SHOULD NOT HAVE LUN=*')  
  1186. X  810 FORMAT(1X,'!!! PAUSE STATEMENTS ARE FROWNED UPON')
  1187. X  820 FORMAT(1X,'!!! STATEMENT SHOULD BE PRECEDED BY A "WRITE"')
  1188. X  830 FORMAT(1X,'!!! ENTRY STATEMENTS DISALLOWED IN FUNCTION')  
  1189. X  840 FORMAT(1X,'!!! ',A,' CLASHES WITH COMMON BLOCK NAME ',A)  
  1190. X  850 FORMAT(/,(1X,I6,'. ',A80))
  1191. X      END   
  1192. /
  1193. echo 'Part 02 of Floppy complete.'
  1194. exit
  1195.  
  1196.  
  1197.