text:
      PROGRAM FM700                                                     00010700
C                                                                       00020700
C     THIS PROGRAM TESTS THE DATA STATEMENT WITH           ANS REF.     00030700
C          VARIABLE NAMES, ARRAY NAMES, ARRAY ELEMENT      9.1          00040700
C          NAMES, SUBSTRING NAMES, AND IMPLIED-DO LISTS.   9.2          00050700
C                                                          9.3          00060700
C     SYMBOLIC NAMES OF CONSTANTS ARE PERMITTED IN THE                  00070700
C          CLIST OF THE DATA STATEMENT.   IF NECESSARY,                 00080700
C          THE CLIST CONSTANT IS CONVERTED TO THE TYPE                  00090700
C          OF THE NLIST ENTITY ACCORDING TO THE RULES                   00100700
C          FOR ARITHMETIC CONVERSION.                                   00110700
C                                                                       00120700
C                                                                       00130700
CBB** ********************** BBCCOMNT **********************************00140700
C****                                                                   00150700
C****            1978 FORTRAN COMPILER VALIDATION SYSTEM                00160700
C****                          VERSION 2.1                              00170700
C****                                                                   00180700
C****                                                                   00190700
C****           SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO         00200700
C****          NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY           00210700
C****               SOFTWARE STANDARDS VALIDATION GROUP                 00220700
C****                      BUILDING 225  RM A266                        00230700
C****                     GAITHERSBURG, MD  20899                       00240700
C****                                                                   00250700
C****                                                                   00260700
C****                                                                   00270700
CBE** ********************** BBCCOMNT **********************************00280700
           IMPLICIT DOUBLE PRECISION (D), COMPLEX (Z), LOGICAL (L)      00290700
           IMPLICIT CHARACTER*27 (C)                                    00300700
CBB** ********************** BBCINITA **********************************00310700
C**** SPECIFICATION STATEMENTS                                          00320700
C****                                                                   00330700
      CHARACTER ZVERS*13, ZVERSD*17, ZDATE*17, ZPROG*5, ZCOMPL*20,      00340700
     1          ZNAME*20, ZTAPE*10, ZPROJ*13, REMRKS*31, ZTAPED*13      00350700
CBE** ********************** BBCINITA **********************************00360700
C                                                                       00370700
      INTEGER I2N001(2,3), I2N002(7), I2N003(3,7)                       00380700
      INTEGER I2N004(3,10), I2N005(4,5), I2N006(6,8)                    00390700
      CHARACTER CVCOMP*25, CVCORR*25, CPN001*5                          00400700
      CHARACTER CVN001*25, CVN002*5, C1N001(3)*5                        00410700
      CHARACTER C2N001(3,4)*4, CVN003*17                                00420700
      REAL R2E001(2), R2N001(5,3)                                       00430700
      DOUBLE PRECISION DVCOMP, DVCORR, DVN001, D1N001(9), DPN001        00440700
      COMPLEX ZVCOMP, ZVCORR, ZVN001, Z1N001(10)                        00450700
      PARAMETER (IPN001=-14, CPN001='SEVEN', IPN002=5, DPN001=0.1948D+3)00460700
      EQUIVALENCE (ZVCOMP, R2E001)                                      00470700
      DATA IVN001, C1N001, I2N001(2,1), CVN001(11:22)                   00480700
     1     /-137, 'FIRST', 'SECND', 'THIRD', 65, 'ELEVENTWELVE'/        00490700
      DATA (I2N001(1,I), I=1,3) /-47, 198, -217/                        00500700
      DATA IVN002, CVN002 /IPN001, CPN001/                              00510700
      DATA I2N002, (I2N003(I,7), I=1,3), C2N001, CVN003(13:16)          00520700
     1     /3*19, 7*-4, 13*'SAME'/                                      00530700
      DATA IVN003, IVN004, RVN001, ZVN001, DVN001, DVN002               00540700
     1     /-0.473E+3, 239.2D-1, 71, (71, -27), 6, 9.1534E-2/           00550700
      DATA (I2N004(2,J), J=1,10) /9,8,7,6,5,4,3,2,1,0/                  00560700
      DATA ((R2N001(I,J), J=1,3), I=3,5)                                00570700
     1     /3.1, 3.2, 3.3, 4.1, 4.2, 4.3, 5.1, 5.2, 5.3/                00580700
      DATA (Z1N001(I), I=3,7) /IPN002*(7.3, -2.28)/                     00590700
      DATA (D1N001(I), I=1,9,2) /IPN002*DPN001/                         00600700
      DATA (I2N005(I,I+1),I=1,4) / 91, -82, 73, -64/                    00610700
      DATA ((I2N006(2*I,I*J-1), I=2,3), J=1,3,2) /41, 62, 45, 68/       00620700
C                                                                       00630700
C                                                                       00640700
CBB** ********************** BBCINITB **********************************00650700
C**** INITIALIZE SECTION                                                00660700
      DATA  ZVERS,                  ZVERSD,             ZDATE           00670700
     1      /'VERSION 2.1  ',  '93/10/21*21.02.00',  '*NO DATE*TIME'/   00680700
      DATA       ZCOMPL,             ZNAME,             ZTAPE           00690700
     1      /'*NONE SPECIFIED*', '*NO COMPANY NAME*', '*NO TAPE*'/      00700700
      DATA       ZPROJ,           ZTAPED,         ZPROG                 00710700
     1      /'*NO PROJECT*',   '*NO TAPE DATE',  'XXXXX'/               00720700
      DATA   REMRKS /'                               '/                 00730700
C**** THE FOLLOWING 9 COMMENT LINES (CZ01, CZ02, ...) CAN BE REPLACED   00740700
C**** FOR IDENTIFYING THE TEST ENVIRONMENT                              00750700
C****                                                                   00760700
CZ01  ZVERS  = 'VERSION OF THE COMPILER VALIDATION SYSTEM'              00770700
CZ02  ZVERSD = 'CREATION DATE/TIME OF THE COMPILER VALIDATION SYSTEM'   00780700
CZ03  ZPROG  = 'PROGRAM NAME'                                           00790700
CZ04  ZDATE  = 'DATE OF TEST'                                           00800700
CZ05  ZCOMPL = 'COMPILER IDENTIFICATION'                                00810700
CZ06  ZPROJ  = 'PROJECT NUMBER/IDENTIFICATION'                          00820700
CZ07  ZNAME  = 'NAME OF USER'                                           00830700
CZ08  ZTAPE  = 'TAPE OWNER/ID'                                          00840700
CZ09  ZTAPED = 'DATE TAPE COPIED'                                       00850700
C                                                                       00860700
      IVPASS = 0                                                        00870700
      IVFAIL = 0                                                        00880700
      IVDELE = 0                                                        00890700
      IVINSP = 0                                                        00900700
      IVTOTL = 0                                                        00910700
      IVTOTN = 0                                                        00920700
      ICZERO = 0                                                        00930700
C                                                                       00940700
C     I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER.         00950700
      I01 = 05                                                          00960700
C     I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER.             00970700
      I02 = 06                                                          00980700
C                                                                       00990700
CX010   REPLACED BY FEXEC X-010 CONTROL CARD (CARD-READER UNIT NUMBER). 01000700
C     THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5      01010700
CX011   REPLACED BY FEXEC X-011 CONTROL CARD.  CX011 IS FOR SYSTEMS     01020700
C     REQUIRING ADDITIONAL STATEMENTS FOR FILES ASSOCIATED WITH CX010.  01030700
C                                                                       01040700
CX020   REPLACED BY FEXEC X-020 CONTROL CARD (PRINTER UNIT NUMBER).     01050700
C     THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02= 6       01060700
CX021   REPLACED BY FEXEC X-021 CONTROL CARD.  CX021 IS FOR SYSTEMS     01070700
C     REQUIRING ADDITIONAL STATEMENTS FOR FILES ASSOCIATED WITH CX020.  01080700
C                                                                       01090700
CBE** ********************** BBCINITB **********************************01100700
           ZPROG = 'FM700'                                              01110700
           IVTOTL = 23                                                  01120700
CBB** ********************** BBCHED0A **********************************01130700
C****                                                                   01140700
C**** WRITE REPORT TITLE                                                01150700
C****                                                                   01160700
      WRITE (I02, 90002)                                                01170700
      WRITE (I02, 90006)                                                01180700
      WRITE (I02, 90007)                                                01190700
      WRITE (I02, 90008)  ZVERS, ZVERSD                                 01200700
      WRITE (I02, 90009)  ZPROG, ZPROG                                  01210700
      WRITE (I02, 90010)  ZDATE, ZCOMPL                                 01220700
CBE** ********************** BBCHED0A **********************************01230700
CBB** ********************** BBCHED0B **********************************01240700
C**** WRITE DETAIL REPORT HEADERS                                       01250700
C****                                                                   01260700
      WRITE (I02,90004)                                                 01270700
      WRITE (I02,90004)                                                 01280700
      WRITE (I02,90013)                                                 01290700
      WRITE (I02,90014)                                                 01300700
      WRITE (I02,90015) IVTOTL                                          01310700
CBE** ********************** BBCHED0B **********************************01320700
C                                                                       01330700
C                                                                       01340700
C          TESTS 1 THRU 5 TEST DATA STATEMENT WITH VARIABLE NAMES,      01350700
C     ARRAY NAMES, ARRAY ELEMENT NAMES, SUBSTRING NAMES, AND IMPLIED-   01360700
C     DO LISTS.                                                         01370700
C                                                                       01380700
CT001*  TEST 001   ****  FCVS PROGRAM 700  *****                        01390700
C     VARIABLE NAME                                                     01400700
C                                                                       01410700
           IVTNUM = 1                                                   01420700
           IVCOMP = 0                                                   01430700
           IVCORR = -137                                                01440700
      IVCOMP = IVN001                                                   01450700
40010      IF (IVCOMP + 137) 20010, 10010, 20010                        01460700
10010      IVPASS = IVPASS + 1                                          01470700
           WRITE (I02, 80002) IVTNUM                                    01480700
           GO TO 0011                                                   01490700
20010      IVFAIL = IVFAIL + 1                                          01500700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    01510700
 0011      CONTINUE                                                     01520700
C                                                                       01530700
CT002*  TEST 002   ****  FCVS PROGRAM 700  *****                        01540700
C     ARRAY NAME                                                        01550700
C                                                                       01560700
           IVTNUM = 2                                                   01570700
           CVCOMP = ' '                                                 01580700
           CVCORR = 'SECND'                                             01590700
      CVCOMP = C1N001(2)                                                01600700
           IVCOMP = 0                                                   01610700
           IF (CVCOMP.EQ.'SECND') IVCOMP = 1                            01620700
40020      IF (IVCOMP - 1) 20020, 10020, 20020                          01630700
10020      IVPASS = IVPASS + 1                                          01640700
           WRITE (I02, 80002) IVTNUM                                    01650700
           GO TO 0021                                                   01660700
20020      IVFAIL = IVFAIL + 1                                          01670700
           WRITE (I02, 80018) IVTNUM, CVCOMP, CVCORR                    01680700
 0021      CONTINUE                                                     01690700
C                                                                       01700700
CT003*  TEST 003   ****  FCVS PROGRAM 700  *****                        01710700
C     ARRAY ELEMENT NAME                                                01720700
C                                                                       01730700
           IVTNUM = 3                                                   01740700
           IVCOMP = 0                                                   01750700
           IVCORR = 65                                                  01760700
      IVCOMP = I2N001(2,1)                                              01770700
40030      IF (IVCOMP - 65) 20030, 10030, 20030                         01780700
10030      IVPASS = IVPASS + 1                                          01790700
           WRITE (I02, 80002) IVTNUM                                    01800700
           GO TO 0031                                                   01810700
20030      IVFAIL = IVFAIL + 1                                          01820700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    01830700
 0031      CONTINUE                                                     01840700
C                                                                       01850700
CT004*  TEST 004   ****  FCVS PROGRAM 700  *****                        01860700
C     SUBSTRING NAME                                                    01870700
C                                                                       01880700
           IVTNUM = 4                                                   01890700
           CVCOMP = ' '                                                 01900700
           CVCORR = 'ELEVENTWELVE'                                      01910700
      CVCOMP = CVN001(11:22)                                            01920700
           IVCOMP = 0                                                   01930700
           IF (CVCOMP.EQ.'ELEVENTWELVE') IVCOMP = 1                     01940700
40040      IF (IVCOMP - 1) 20040, 10040, 20040                          01950700
10040      IVPASS = IVPASS + 1                                          01960700
           WRITE (I02, 80002) IVTNUM                                    01970700
           GO TO 0041                                                   01980700
20040      IVFAIL = IVFAIL + 1                                          01990700
           WRITE (I02, 80018) IVTNUM, CVCOMP, CVCORR                    02000700
 0041      CONTINUE                                                     02010700
C                                                                       02020700
CT005*  TEST 005   ****  FCVS PROGRAM 700  *****                        02030700
C     IMPLIED-DO LIST                                                   02040700
C                                                                       02050700
           IVTNUM = 5                                                   02060700
           IVCOMP = 0                                                   02070700
           IVCORR = -217                                                02080700
      IVCOMP = I2N001(1,3)                                              02090700
40050      IF (IVCOMP + 217) 20050, 10050, 20050                        02100700
10050      IVPASS = IVPASS + 1                                          02110700
           WRITE (I02, 80002) IVTNUM                                    02120700
           GO TO 0051                                                   02130700
20050      IVFAIL = IVFAIL + 1                                          02140700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    02150700
 0051      CONTINUE                                                     02160700
C                                                                       02170700
CT006*  TEST 006   ****  FCVS PROGRAM 700  *****                        02180700
C     CLIST CONTAINS A SYMBOLIC NAME OF AN INTEGER CONSTANT             02190700
C                                                                       02200700
           IVTNUM = 6                                                   02210700
           IVCOMP = 0                                                   02220700
           IVCORR = -14                                                 02230700
      IVCOMP = IVN002                                                   02240700
40060      IF (IVCOMP + 14) 20060, 10060, 20060                         02250700
10060      IVPASS = IVPASS + 1                                          02260700
           WRITE (I02, 80002) IVTNUM                                    02270700
           GO TO 0061                                                   02280700
20060      IVFAIL = IVFAIL + 1                                          02290700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    02300700
 0061      CONTINUE                                                     02310700
C                                                                       02320700
CT007*  TEST 007   ****  FCVS PROGRAM 700  *****                        02330700
C     CLIST CONTAINS A SYMBOLIC NAME OF A CHARACTER CONSTANT            02340700
C                                                                       02350700
           IVTNUM = 7                                                   02360700
           CVCOMP = ' '                                                 02370700
           CVCORR = 'SEVEN'                                             02380700
      CVCOMP = CVN002                                                   02390700
           IVCOMP = 0                                                   02400700
           IF (CVCOMP.EQ.'SEVEN') IVCOMP = 1                            02410700
40070      IF (IVCOMP - 1) 20070, 10070, 20070                          02420700
10070      IVPASS = IVPASS + 1                                          02430700
           WRITE (I02, 80002) IVTNUM                                    02440700
           GO TO 0071                                                   02450700
20070      IVFAIL = IVFAIL + 1                                          02460700
           WRITE (I02, 80018) IVTNUM, CVCOMP, CVCORR                    02470700
 0071      CONTINUE                                                     02480700
C                                                                       02490700
C          TESTS 8 THRU 11 TEST COMBINATIONS OF SUBSTRING NAMES AND     02500700
C     ARRAY NAMES AND THE R*C FORMAT OF THE CLIST                       02510700
C                                                                       02520700
CT008*  TEST 008   ****  FCVS PROGRAM 700  *****                        02530700
C                                                                       02540700
           IVTNUM = 8                                                   02550700
           IVCOMP = 0                                                   02560700
           IVCORR = 23                                                  02570700
      IVCOMP = I2N002(3) - I2N002(4)                                    02580700
40080      IF (IVCOMP - 23) 20080, 10080, 20080                         02590700
10080      IVPASS = IVPASS + 1                                          02600700
           WRITE (I02, 80002) IVTNUM                                    02610700
           GO TO 0081                                                   02620700
20080      IVFAIL = IVFAIL + 1                                          02630700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    02640700
 0081      CONTINUE                                                     02650700
C                                                                       02660700
CT009*  TEST 009   ****  FCVS PROGRAM 700  *****                        02670700
C                                                                       02680700
           IVTNUM = 9                                                   02690700
           IVCOMP = 0                                                   02700700
           IVCORR = -4                                                  02710700
      DO 0092 I = 1, 3                                                  02720700
      IF (I2N003(I,7) + 4) 0093, 0092, 0093                             02730700
0092  CONTINUE                                                          02740700
0093  IVCOMP = I2N003(3,7)                                              02750700
40090      IF (IVCOMP + 4) 20090, 10090, 20090                          02760700
10090      IVPASS = IVPASS + 1                                          02770700
           WRITE (I02, 80002) IVTNUM                                    02780700
           GO TO 0091                                                   02790700
20090      IVFAIL = IVFAIL + 1                                          02800700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    02810700
 0091      CONTINUE                                                     02820700
C                                                                       02830700
CT010*  TEST 010   ****  FCVS PROGRAM 700  *****                        02840700
C                                                                       02850700
           IVTNUM = 10                                                  02860700
           CVCOMP = ' '                                                 02870700
           CVCORR = 'SAME'                                              02880700
      DO 0102 I = 1, 3                                                  02890700
      DO 0102 J = 1, 4                                                  02900700
      IF (C2N001(I,J).NE.'SAME') GO TO 0103                             02910700
0102  CONTINUE                                                          02920700
0103  CVCOMP = C2N001(3,4)                                              02930700
           IVCOMP = 0                                                   02940700
           IF (CVCOMP.EQ.'SAME') IVCOMP = 1                             02950700
40100      IF (IVCOMP - 1) 20100, 10100, 20100                          02960700
10100      IVPASS = IVPASS + 1                                          02970700
           WRITE (I02, 80002) IVTNUM                                    02980700
           GO TO 0101                                                   02990700
20100      IVFAIL = IVFAIL + 1                                          03000700
           WRITE (I02, 80018) IVTNUM, CVCOMP, CVCORR                    03010700
 0101      CONTINUE                                                     03020700
C                                                                       03030700
CT011*  TEST 011   ****  FCVS PROGRAM 700  *****                        03040700
C                                                                       03050700
           IVTNUM = 11                                                  03060700
           CVCOMP = ' '                                                 03070700
           CVCORR = 'SAME'                                              03080700
      CVCOMP = CVN003(13:16)                                            03090700
           IVCOMP = 0                                                   03100700
           IF (CVCOMP.EQ.'SAME') IVCOMP = 1                             03110700
40110      IF (IVCOMP - 1) 20110, 10110, 20110                          03120700
10110      IVPASS = IVPASS + 1                                          03130700
           WRITE (I02, 80002) IVTNUM                                    03140700
           GO TO 0111                                                   03150700
20110      IVFAIL = IVFAIL + 1                                          03160700
           WRITE (I02, 80018) IVTNUM, CVCOMP, CVCORR                    03170700
 0111      CONTINUE                                                     03180700
C                                                                       03190700
C          TESTS 12 THRU 17 TEST ARITHMETIC CONVERSION OF CLIST         03200700
C     CONSTANTS TO THE TYPE OF THE CORRESPONDING NLIST ENTITIES         03210700
C                                                                       03220700
CT012*  TEST 012   ****  FCVS PROGRAM 700  *****                        03230700
C     REAL TO INTEGER                                                   03240700
C                                                                       03250700
           IVTNUM = 12                                                  03260700
           IVCOMP = 0                                                   03270700
           IVCORR =  -473                                               03280700
      IVCOMP = IVN003                                                   03290700
40120      IF (IVCOMP + 473) 20120, 10120, 20120                        03300700
10120      IVPASS = IVPASS + 1                                          03310700
           WRITE (I02, 80002) IVTNUM                                    03320700
           GO TO 0121                                                   03330700
20120      IVFAIL = IVFAIL + 1                                          03340700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    03350700
 0121      CONTINUE                                                     03360700
C                                                                       03370700
CT013*  TEST 013   ****  FCVS PROGRAM 700  *****                        03380700
C     DOUBLE PRECISION TO INTEGER                                       03390700
C                                                                       03400700
           IVTNUM = 13                                                  03410700
           IVCOMP = 0                                                   03420700
           IVCORR = 23                                                  03430700
      IVCOMP = IVN004                                                   03440700
40130      IF (IVCOMP - 23) 20130, 10130, 20130                         03450700
10130      IVPASS = IVPASS + 1                                          03460700
           WRITE (I02, 80002) IVTNUM                                    03470700
           GO TO 0131                                                   03480700
20130      IVFAIL = IVFAIL + 1                                          03490700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    03500700
 0131      CONTINUE                                                     03510700
C                                                                       03520700
CT014*  TEST 014   ****  FCVS PROGRAM 700  *****                        03530700
C     INTEGER TO REAL                                                   03540700
C                                                                       03550700
           IVTNUM = 14                                                  03560700
           RVCOMP = 0.0                                                 03570700
           RVCORR = 71.0                                                03580700
      RVCOMP = RVN001                                                   03590700
           IF (RVCOMP - 0.70996E+02) 20140, 10140, 40140                03600700
40140      IF (RVCOMP - 0.71004E+02) 10140, 10140, 20140                03610700
10140      IVPASS = IVPASS + 1                                          03620700
           WRITE (I02, 80002) IVTNUM                                    03630700
           GO TO 0141                                                   03640700
20140      IVFAIL = IVFAIL + 1                                          03650700
           WRITE (I02, 80012) IVTNUM, RVCOMP, RVCORR                    03660700
 0141      CONTINUE                                                     03670700
C                                                                       03680700
CT015*  TEST 015   ****  FCVS PROGRAM 700  *****                        03690700
C     COMPLEX                                                           03700700
C                                                                       03710700
           IVTNUM = 15                                                  03720700
           ZVCOMP = (0.0, 0.0)                                          03730700
           ZVCORR = (71.0, -27.0)                                       03740700
      ZVCOMP = ZVN001                                                   03750700
           IF (R2E001(1) - 0.70996E+02) 20150, 40152, 40151             03760700
40151      IF (R2E001(1) - 0.71004E+02) 40152, 40152, 20150             03770700
40152      IF (R2E001(2) + 0.27002E+02) 20150, 10150, 40150             03780700
40150      IF (R2E001(2) + 0.26998E+02) 10150, 10150, 20150             03790700
10150      IVPASS = IVPASS + 1                                          03800700
           WRITE (I02, 80002) IVTNUM                                    03810700
           GO TO 0151                                                   03820700
20150      IVFAIL = IVFAIL + 1                                          03830700
           WRITE (I02, 80045) IVTNUM, ZVCOMP, ZVCORR                    03840700
 0151      CONTINUE                                                     03850700
C                                                                       03860700
CT016*  TEST 016   ****  FCVS PROGRAM 700  *****                        03870700
C     INTEGER TO DOUBLE PRECISION                                       03880700
C                                                                       03890700
           IVTNUM = 16                                                  03900700
           DVCOMP = 0.0D0                                               03910700
           DVCORR = 6.0D0                                               03920700
      DVCOMP = DVN001                                                   03930700
           IF (DVCOMP - 0.5999999997D+01) 20160, 10160, 40160           03940700
40160      IF (DVCOMP - 0.6000000003D+01) 10160, 10160, 20160           03950700
10160      IVPASS = IVPASS + 1                                          03960700
           WRITE (I02, 80002) IVTNUM                                    03970700
           GO TO 0161                                                   03980700
20160      IVFAIL = IVFAIL + 1                                          03990700
           WRITE (I02, 80031) IVTNUM, DVCOMP, DVCORR                    04000700
 0161      CONTINUE                                                     04010700
C                                                                       04020700
CT017*  TEST 017   ****  FCVS PROGRAM 700  *****                        04030700
C     REAL TO DOUBLE PRECISION                                          04040700
C                                                                       04050700
           IVTNUM = 17                                                  04060700
           DVCOMP = 0.0D0                                               04070700
           DVCORR = 9.1534D-2                                           04080700
      DVCOMP = DVN002                                                   04090700
           IF (DVCOMP - 0.91529D-01) 20170, 10170, 40170                04100700
40170      IF (DVCOMP - 0.91539D-01) 10170, 10170, 20170                04110700
10170      IVPASS = IVPASS + 1                                          04120700
           WRITE (I02, 80002) IVTNUM                                    04130700
           GO TO 0171                                                   04140700
20170      IVFAIL = IVFAIL + 1                                          04150700
           WRITE (I02, 80031) IVTNUM, DVCOMP, DVCORR                    04160700
 0171      CONTINUE                                                     04170700
C                                                                       04180700
C     TESTS 18 THRU 21 TEST DIFFERENT DATA TYPES USING THE IMPLIED-DO   04190700
C                                                                       04200700
CT018*  TEST 018   ****  FCVS PROGRAM 700  *****                        04210700
C     INTEGER                                                           04220700
C                                                                       04230700
           IVTNUM = 18                                                  04240700
           IVCOMP = 0                                                   04250700
           IVCORR = 3                                                   04260700
      IVCOMP = I2N004(2,7)                                              04270700
40180      IF (IVCOMP - 3) 20180, 10180, 20180                          04280700
10180      IVPASS = IVPASS + 1                                          04290700
           WRITE (I02, 80002) IVTNUM                                    04300700
           GO TO 0181                                                   04310700
20180      IVFAIL = IVFAIL + 1                                          04320700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    04330700
 0181      CONTINUE                                                     04340700
C                                                                       04350700
CT019*  TEST 019   ****  FCVS PROGRAM 700  *****                        04360700
C     REAL                                                              04370700
C                                                                       04380700
           IVTNUM = 19                                                  04390700
           RVCOMP = 0.0                                                 04400700
           RVCORR = 4.1                                                 04410700
      RVCOMP = R2N001(4,1)                                              04420700
           IF (RVCOMP - 0.40998E+01) 20190, 10190, 40190                04430700
40190      IF (RVCOMP - 0.41002E+01) 10190, 10190, 20190                04440700
10190      IVPASS = IVPASS + 1                                          04450700
           WRITE (I02, 80002) IVTNUM                                    04460700
           GO TO 0191                                                   04470700
20190      IVFAIL = IVFAIL + 1                                          04480700
           WRITE (I02, 80012) IVTNUM, RVCOMP, RVCORR                    04490700
 0191      CONTINUE                                                     04500700
C                                                                       04510700
CT020*  TEST 020   ****  FCVS PROGRAM 700  *****                        04520700
C     COMPLEX                                                           04530700
C                                                                       04540700
           IVTNUM = 20                                                  04550700
           ZVCOMP = (0.0, 0.0)                                          04560700
           ZVCORR = (7.3, -2.28)                                        04570700
      ZVCOMP = Z1N001(7)                                                04580700
           IF (R2E001(1) - 0.72996E+01) 20200, 40202, 40201             04590700
40201      IF (R2E001(1) - 0.73004E+01) 40202, 40202, 20200             04600700
40202      IF (R2E001(2) + 0.22802E+01) 20200, 10200, 40200             04610700
40200      IF (R2E001(2) + 0.22798E+01) 10200, 10200, 20200             04620700
10200      IVPASS = IVPASS + 1                                          04630700
           WRITE (I02, 80002) IVTNUM                                    04640700
           GO TO 0201                                                   04650700
20200      IVFAIL = IVFAIL + 1                                          04660700
           WRITE (I02, 80045) IVTNUM, ZVCOMP, ZVCORR                    04670700
 0201      CONTINUE                                                     04680700
C                                                                       04690700
CT021*  TEST 021   ****  FCVS PROGRAM 700  *****                        04700700
C     DOUBLE PRECISION                                                  04710700
C                                                                       04720700
           IVTNUM = 21                                                  04730700
           DVCOMP = 0.0D0                                               04740700
           DVCORR = 0.1948D+3                                           04750700
      DVCOMP = D1N001(9)                                                04760700
           IF (DVCOMP - 0.1947999999D+03) 20210, 10210, 40210           04770700
40210      IF (DVCOMP - 0.1948000001D+03) 10210, 10210, 20210           04780700
10210      IVPASS = IVPASS + 1                                          04790700
           WRITE (I02, 80002) IVTNUM                                    04800700
           GO TO 0211                                                   04810700
20210      IVFAIL = IVFAIL + 1                                          04820700
           WRITE (I02, 80031) IVTNUM, DVCOMP, DVCORR                    04830700
 0211      CONTINUE                                                     04840700
C                                                                       04850700
C          TESTS 22 AND 23 TEST THAT EACH SUBSCRIPT EXPRESSION          04860700
C     IN AN IMPLIED-DO LIST MAY CONTAIN IMPLIED-DO-VARIABLES OF         04870700
C     THE LIST THAT HAS THE SUBSCRIPT EXPRESSION WITHIN ITS RANGE.      04880700
C                                                                       04890700
CT022*  TEST 022   ****  FCVS PROGRAM 700  *****                        04900700
C                                                                       04910700
           IVTNUM = 22                                                  04920700
           IVCOMP = 0                                                   04930700
           IVCORR = 155                                                 04940700
      IVCOMP = I2N005(3,4) - I2N005(2,3)                                04950700
40220      IF (IVCOMP - 155) 20220, 10220, 20220                        04960700
10220      IVPASS = IVPASS + 1                                          04970700
           WRITE (I02, 80002) IVTNUM                                    04980700
           GO TO 0221                                                   04990700
20220      IVFAIL = IVFAIL + 1                                          05000700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    05010700
 0221      CONTINUE                                                     05020700
C                                                                       05030700
CT023*  TEST 023   ****  FCVS PROGRAM 700  *****                        05040700
C                                                                       05050700
           IVTNUM = 23                                                  05060700
           IVCOMP = 0                                                   05070700
           IVCORR = 130                                                 05080700
      IVCOMP = I2N006(6,2) + I2N006(6,8)                                05090700
40230      IF (IVCOMP - 130) 20230, 10230, 20230                        05100700
10230      IVPASS = IVPASS + 1                                          05110700
           WRITE (I02, 80002) IVTNUM                                    05120700
           GO TO 0231                                                   05130700
20230      IVFAIL = IVFAIL + 1                                          05140700
           WRITE (I02, 80010) IVTNUM, IVCOMP, IVCORR                    05150700
 0231      CONTINUE                                                     05160700
C                                                                       05170700
CBB** ********************** BBCSUM0  **********************************05180700
C**** WRITE OUT TEST SUMMARY                                            05190700
C****                                                                   05200700
      IVTOTN = IVPASS + IVFAIL + IVDELE + IVINSP                        05210700
      WRITE (I02, 90004)                                                05220700
      WRITE (I02, 90014)                                                05230700
      WRITE (I02, 90004)                                                05240700
      WRITE (I02, 90020) IVPASS                                         05250700
      WRITE (I02, 90022) IVFAIL                                         05260700
      WRITE (I02, 90024) IVDELE                                         05270700
      WRITE (I02, 90026) IVINSP                                         05280700
      WRITE (I02, 90028) IVTOTN, IVTOTL                                 05290700
CBE** ********************** BBCSUM0  **********************************05300700
CBB** ********************** BBCFOOT0 **********************************05310700
C**** WRITE OUT REPORT FOOTINGS                                         05320700
C****                                                                   05330700
      WRITE (I02,90016) ZPROG, ZPROG                                    05340700
      WRITE (I02,90018) ZPROJ, ZNAME, ZTAPE, ZTAPED                     05350700
      WRITE (I02,90019)                                                 05360700
CBE** ********************** BBCFOOT0 **********************************05370700
90001 FORMAT (" ",56X,"FM700")                                          05380700
90000 FORMAT (" ",50X,"END OF PROGRAM FM700" )                          05390700
CBB** ********************** BBCFMT0A **********************************05400700
C**** FORMATS FOR TEST DETAIL LINES                                     05410700
C****                                                                   05420700
80000 FORMAT (" ",2X,I3,4X,"DELETED",32X,A31)                           05430700
80002 FORMAT (" ",2X,I3,4X," PASS  ",32X,A31)                           05440700
80004 FORMAT (" ",2X,I3,4X,"INSPECT",32X,A31)                           05450700
80008 FORMAT (" ",2X,I3,4X," FAIL  ",32X,A31)                           05460700
80010 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",15X,"COMPUTED= " ,           05470700
     1I6,/," ",15X,"CORRECT=  " ,I6)                                    05480700
80012 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           05490700
     1E12.5,/," ",16X,"CORRECT=  " ,E12.5)                              05500700
80018 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           05510700
     1A21,/," ",16X,"CORRECT=  " ,A21)                                  05520700
80020 FORMAT (" ",16X,"COMPUTED= " ,A21,1X,A31)                         05530700
80022 FORMAT (" ",16X,"CORRECT=  " ,A21,1X,A31)                         05540700
80024 FORMAT (" ",16X,"COMPUTED= " ,I6,16X,A31)                         05550700
80026 FORMAT (" ",16X,"CORRECT=  " ,I6,16X,A31)                         05560700
80028 FORMAT (" ",16X,"COMPUTED= " ,E12.5,10X,A31)                      05570700
80030 FORMAT (" ",16X,"CORRECT=  " ,E12.5,10X,A31)                      05580700
80050 FORMAT (" ",48X,A31)                                              05590700
CBE** ********************** BBCFMT0A **********************************05600700
CBB** ********************** BBCFMAT1 **********************************05610700
C**** FORMATS FOR TEST DETAIL LINES - FULL LANGUAGE                     05620700
C****                                                                   05630700
80031 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           05640700
     1D17.10,/," ",16X,"CORRECT=  " ,D17.10)                            05650700
80033 FORMAT (" ",16X,"COMPUTED= " ,D17.10,10X,A31)                     05660700
80035 FORMAT (" ",16X,"CORRECT=  " ,D17.10,10X,A31)                     05670700
80037 FORMAT (" ",16X,"COMPUTED= " ,"(",E12.5,", ",E12.5,")",6X,A31)    05680700
80039 FORMAT (" ",16X,"CORRECT=  " ,"(",E12.5,", ",E12.5,")",6X,A31)    05690700
80041 FORMAT (" ",16X,"COMPUTED= " ,"(",F12.5,", ",F12.5,")",6X,A31)    05700700
80043 FORMAT (" ",16X,"CORRECT=  " ,"(",F12.5,", ",F12.5,")",6X,A31)    05710700
80045 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           05720700
     1"(",F12.5,", ",F12.5,")"/," ",16X,"CORRECT=  " ,                  05730700
     2"(",F12.5,", ",F12.5,")")                                         05740700
CBE** ********************** BBCFMAT1 **********************************05750700
CBB** ********************** BBCFMT0B **********************************05760700
C**** FORMAT STATEMENTS FOR PAGE HEADERS                                05770700
C****                                                                   05780700
90002 FORMAT ("1")                                                      05790700
90004 FORMAT (" ")                                                      05800700
90006 FORMAT (" ",20X,"NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY" )05810700
90007 FORMAT (" ",19X,"FORTRAN COMPILER VALIDATION SYSTEM" )            05820700
90008 FORMAT (" ",21X,A13,A17)                                          05830700
90009 FORMAT (" ",/," *",A5,"BEGIN*",12X,"TEST RESULTS - " ,A5,/)       05840700
90010 FORMAT (" ",8X,"TEST DATE*TIME= " ,A17,"  -  COMPILER= " ,A20)    05850700
90013 FORMAT (" "," TEST   ","PASS/FAIL " ,6X,"DISPLAYED RESULTS" ,     05860700
     1       7X,"REMARKS",24X)                                          05870700
90014 FORMAT (" ","----------------------------------------------" ,    05880700
     1        "---------------------------------" )                     05890700
90015 FORMAT (" ",48X,"THIS PROGRAM HAS " ,I3," TESTS",/)               05900700
C****                                                                   05910700
C**** FORMAT STATEMENTS FOR REPORT FOOTINGS                             05920700
C****                                                                   05930700
90016 FORMAT (" ",/," *",A5,"END*",14X,"END OF TEST - " ,A5,/)          05940700
90018 FORMAT (" ",A13,13X,A20,"   *   ",A10,"/",                        05950700
     1        A13)                                                      05960700
90019 FORMAT (" ","FOR OFFICIAL USE ONLY     " ,35X,"COPYRIGHT  1982" ) 05970700
C****                                                                   05980700
C**** FORMAT STATEMENTS FOR RUN SUMMARY                                 05990700
C****                                                                   06000700
90020 FORMAT (" ",21X,I5," TESTS PASSED" )                              06010700
90022 FORMAT (" ",21X,I5," TESTS FAILED" )                              06020700
90024 FORMAT (" ",21X,I5," TESTS DELETED" )                             06030700
90026 FORMAT (" ",21X,I5," TESTS REQUIRE INSPECTION" )                  06040700
90028 FORMAT (" ",21X,I5," OF ",I3," TESTS EXECUTED" )                  06050700
CBE** ********************** BBCFMT0B **********************************06060700
      STOP                                                              06070700
      END                                                               06080700

max_stars_repo_name: MrSidims/llvm-test-suite

max_issues_repo_name: MrSidims/llvm-test-suite

max_forks_repo_name: MrSidims/llvm-test-suite


text:
      subroutine number(x,y,z,fnum,n,th)
	character in
      dimension in(10)
      common /gftab/irdb(5),rdb(17)
      data in/'0','1','2','3','4','5','6','7','8','9'/
      h	= abs(z)
      f	= rdb(17)/rdb(1)
      if(h.lt.0.1*f) return
      if(z.ge.0.) call symbol(x,y,0.1*f,' ',1,th)
      if(fnum.lt.0.) call symbol (0.,0.,h,'-',-1,th)
      f	= abs(fnum)
      nn = n
      q	= 10.**(-nn)
      if(nn.ge.0) goto 1
      i	= (f + 1e-6)/q
      nn = 0
      goto 2
 1    f	= f +0.5*q
      i	= int(f)
      f	= f - i
C  i - tselaja chast chisla
 2    l	= alog10(float(i) + 1e-6) + 1.0 + 1e-6
      if(l.lt.0) l=1
      do 3 j=1,l
	m = i/10**(l-j)
	m = mod(m,10)+1
	call symbol(0.,0.,h,in(m),-1,th)
 3	continue
      if(nn.eq.0) return
C  f - drobnaja chast chisla
      call symbol(0.,0.,h,'.',-1,th)
      do 4 j=1,nn
	f = f*10.
	m = f
	f = f-m
	call symbol(0.,0.,h,in(m+1),-1,th)
 4	continue
      return
      end

ext: f

max_stars_repo_name: sergev/grafor

max_issues_repo_name: sergev/grafor

max_forks_repo_name: sergev/grafor


! { dg-do  run }
! { dg-shouldfail "STOP 1" }
program main
  stop 1
end program main


text:
  !! Local Variables
  INTEGER :: total_columns, total_values
  INTEGER :: inner_start, inner_length
  INTEGER :: outer_start, outer_length
  INTEGER :: outer_offset
  INTEGER :: counter
  INTEGER :: size_of_mat

  CALL DestructMatrix(out_matrix)

  !! Figure Out The Sizes
  total_columns = 0
  total_values  = 0
  DO counter = LBOUND(mat_list,dim=1), UBOUND(mat_list,dim=1)
     total_columns = total_columns + mat_list(counter)%columns
     size_of_mat = mat_list(counter)%outer_index(mat_list(counter)%columns+1)
     total_values  = total_values + size_of_mat
  END DO

  !! Allocate The Space
  CALL ConstructEmptyMatrix(out_matrix, mat_list(1)%rows, total_columns)
  ALLOCATE(out_matrix%inner_index(total_values))
  ALLOCATE(out_matrix%values(total_values))

  !! Fill In The Values
  inner_start = 1
  outer_start = 1
  outer_offset = 0
  DO counter = LBOUND(mat_list,dim=1),UBOUND(mat_list,dim=1)
     !! Inner indices and values
     size_of_mat = mat_list(counter)%outer_index(mat_list(counter)%columns+1)
     inner_length = size_of_mat
     out_matrix%inner_index(inner_start:inner_start+inner_length-1) = &
          & mat_list(counter)%inner_index
     out_matrix%values(inner_start:inner_start+inner_length-1) = &
          & mat_list(counter)%values
     inner_start = inner_start + inner_length
     !! Outer Indices
     outer_length = mat_list(counter)%columns+1
     out_matrix%outer_index(outer_start:outer_start+outer_length-1) = &
          & mat_list(counter)%outer_index + outer_offset
     outer_start = outer_start + outer_length - 1
     outer_offset = out_matrix%outer_index(outer_start)
  END DO

max_stars_repo_name: Kokookster/NTPoly

max_issues_repo_name: omni-compiler/NTPoly

max_forks_repo_name: omni-compiler/NTPoly


  program pseudo

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !PROGRAM: pseudo - Pseudo-inverse fields based on forecast error projection
!
! !USES:

  use m_mpif90,only : MP_init
  use m_mpif90,only : MP_finalize
  use m_mpif90,only : MP_comm_rank
  use m_mpif90,only : MP_comm_world

  use m_pseudo, only : pseudo_set
  use m_pseudo, only : pseudo_process
  use m_pseudo, only : pseudo_clean

  use m_die, only : MP_die, die

  implicit none

! !DESCRIPTION:
!
! !REVISION HISTORY:
!
!  05Dec2005  RG/EN   Adopted similarity calculation code to create this program
!  02Feb2007  Todling    Placed mpi hooks (only runs in 1 pe)
!
!EOP
!-------------------------------------------------------------------------

  character(len=*), parameter :: myname= 'pseudoInverse'

  integer, parameter :: ROOT = 0 ! MPI ROOT PE

  character(len=255) :: RCfile
  character(len=255) :: jobR

  integer :: nvecsA
  integer :: nvecsB
  integer :: ntimes               !  number of dates and times examined
  integer :: nymd                 ! date (YYYYMMDD) of stats
  integer :: nhms                 ! time   (HHMMSS) of stats
  character(len=255) :: FSVEC
  character(len=255) :: ISVEC
  character(len=255), allocatable :: jobB(:)
  character(len=255) :: svalu_file
  character(len=255) :: dynfiles(4)             ! intent to output 4 dynamic vectors:
                                                ! 1. forecast error
                                                ! 2. forecast error projected on nvecsA EVOLVED SVECs
                                                ! 3. pseudo-inverse fields
                                                ! 4. sensitivity projected on nvecsA INITIAL SVECs
  integer :: myID, ier

! MPI Initialization
! ------------------
  call MP_init(ier)
        if(ier/=0) call MP_die(myname,'MP_init()',ier)
  call MP_comm_rank(MP_comm_world,myID,ier)
        if(ier/=0) call MP_die(myname,'MP_comm_rank()',ier)

  nvecsB = 2

! Parse command line
! ------------------
  call Init_ ( nvecsA, dynfiles, RCfile )

! Set up program's options
! ------------------------
  allocate ( jobB(nvecsB) )
  call pseudo_Set ( MP_comm_world, root,    &
                     nvecsA, nvecsB, jobR, FSVEC, ISVEC, svalu_file, jobB,          &
                     RCfile, ier )
     if(ier/=0) call die(myname,'could not setup run')

! Generate initial perturbation
! -----------------------------
  call pseudo_Process ( nvecsA, nvecsB, &
                         jobR, FSVEC, ISVEC, svalu_file, jobB, dynfiles, RCfile)

! Clean up
! --------
  deallocate ( jobB )
  call pseudo_Clean( )

  call MP_finalize(ier)
        if(ier/=0) call MP_die(myname,'MP_finalized()',ier)

 contains

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOP
! !IROUTINE: Init_ --- Initialize
!
! !DESCRIPTION: parses command line.
!
! !INTERFACE:
!
      subroutine Init_ ( nvecsA, dynfiles, RCfile )

      implicit NONE

      integer,       intent(out) :: nvecsA
      character*255, intent(out) :: dynfiles(4)
      character*255, intent(out) :: RCfile     ! resource file

!
! !REVISION HISTORY:
!      10Dec2005    EN   Adopted simsv.f90 to create this application
!
!EOP
!BOC

      character*4, parameter :: myname = 'init'

      integer iret, i, iarg, argc, iargc
      logical verb
      character(len=255) :: argv, res
      character*10 str

!     Defaults
!     --------
      RCfile   ='pseudo.rc'   ! default not to use an RCfile
      dynfiles(1) = 'FCSTERR.nc4'
      dynfiles(2) = 'PROJFERR.nc4'
      dynfiles(3) = 'PSEUDO.nc4'
      dynfiles(4) = 'PROJSENS.nc4'
      nvecsA = 1

!     Parse command line
!     ------------------
      argc =  iargc()
      if ( argc .lt. 1 ) call usage()

      iarg = 0

      do i = 1, 32767
         iarg = iarg + 1
         if ( iarg .gt. argc ) exit
         call GetArg ( iarg, argv )
         select case (argv)
           case ("-nsvecs")
             if ( iarg+1 .gt. argc ) call usage()
             iarg = iarg + 1
             call GetArg ( iarg, str )
             read(str,*) nvecsA
           case ("-rc")
             if ( iarg+1 .gt. argc ) call usage()
             iarg = iarg + 1
             call GetArg ( iarg, RCfile )
           case ("-fcsterr")
             if ( iarg+1 .gt. argc ) call usage()
             iarg = iarg + 1
             call GetArg ( iArg, dynfiles(1) )
           case ("-projferr")
             if ( iarg+1 .gt. argc ) call usage()
             iarg = iarg + 1
             call GetArg ( iArg, dynfiles(2) )
           case ("-pseudo")
             if ( iarg+1 .gt. argc ) call usage()
             iarg = iarg + 1
             call GetArg ( iArg, dynfiles(3) )
           case ("-projsens")
             if ( iarg+1 .gt. argc ) call usage()
             iarg = iarg + 1
             call GetArg ( iArg, dynfiles(4) )
           case default
             call die(myname,'not a valid option')
         end select
      end do

      if (nvecsA .lt. 1) then
         print *
         print *, ' Error: No SVECs in a list '
         print *, '     Exiting on error    '
         print *
         stop
      endif

      end subroutine Init_

!.................................................................

      subroutine usage()
      print *
      print *, '  -------------------------------------------------------------------'
      print *, '  pseudo.x - computes full and projected forecast error, pseudo-inverse'
      print *, '                     and projected sensitivity'
      print *, '  -------------------------------------------------------------------'
      print *
      print *
      print *,'Usage: '
      print *,'  pseudo.x -nsvecs NSVECS -rc RCfile '
      print *,'          [-fcsterr dynfile1] [-projferr dynfile2] [-pseudo dynfile3]'
      print *,'          [-projsens dynfile4] '
      print *
      print *, 'where'
      print *
      print *, '-nsvecs   NSVECS   number of SVECS to be used for projection'
      print *
      print *, '-rc       RCfile   resource filename '
      print *, '              (default: pseudo.rc)'
      print *
      print *, '-fcsterr  dynfile1   Filename to write out forecast error'
      print *, '              (default:  FCSTERR.nc4)'
      print *
      print *, '-projferr dynfile2   Filename to write out projected forecast error'
      print *, '              (default:  PROJFERR.nc4)'
      print *
      print *, '-pseudo   dynfile3   Filename to write out pseudo-inverse fileds'
      print *, '              (default:  PSEUDO.nc4)'
      print *
      print *, '-projsens dynfile4   Filename to write out projected sensitivity'
      print *, '              (default:  PROJSENS.nc4)'
      print *
      print *, ' Last updated: 05 Mar 2009 Todling '
      print *
      call MP_finalize(ier)
        if(ier/=0) call MP_die(myname,'MP_finalized()',ier)
      call exit(1)
      end subroutine usage

!.................................................................

 end program pseudo


text:
C    %W% %G%
        subroutine openpf(pfname,*)
        character *(*) pfname

        include 'ipfinc/dtaiop.inc'
        include 'ipfinc/lfiles.inc'

        character*10 pfcase

        datai = 3
	open (unit=datai,
     &        file=pfname,
     &        status='OLD',
c    &        readonly,
     &        form='UNFORMATTED',
c    &        shared,
     &        err=100)

        go to 200

100     return 1

200     pfcase = ' '
C
C      	OBTAIN DATA FROM INPUT FILE
C	Search DATAI OLDBASE for PFcase and load it into common
C        LOADED = 0 WHEN PFCASE WAS NOT FOUND IN DATAI
C               = 1 WHEN PFCASE WAS FOUND AND LOADED
C               = 2 WHEN DATAI WAS NOT A "PF DATA" HISTORY FILE
C
C	Open PF oldbase and load PFcase
C
        pfcase = ' '
        call rddtai(pfcase,loaded)

C
C       IF COUNT(1) = 0 THEN YOU HAVE A FAILED SOLUTION PF CASE.
C                   = 1 THEN YOU HAVE A SOLVED SOLUTION PF CASE.
C
        if ( count(1).eq.0) then
           write (*,105)
105        format (' THIS IS A FAILED SOLUTION CASE')
        endif

        if (loaded.eq.0) then
           write (*,110)
110        format (' CASE NOT ON OLD-BASE FILE')
        else if (loaded.eq.2) then
           write (*,115)
115        format (' NOT A POWERFLOW  OLD-BASE FILE')
        else if(loaded.ge.3) then
           write (*,120)
120        format (' CASE NOT ACCESSIBLE')
        endif

        close (unit = datai)

        if ((count(1).eq.0) .or. (loaded.ne.1)) return 1

        return

	end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
 !! ---------------------------------------------------------------------------
 !! ---------------------------------------------------------------------------
 !! ---------------------------------------------------------------------------
 !!
 !!    Copyright (c) 2018-2020, Universita' di Padova, Manuele Faccenda
 !!    All rights reserved.
 !!
 !!    This software package was developed at:
 !!
 !!         Dipartimento di Geoscienze
 !!         Universita' di Padova, Padova
 !!         via Gradenigo 6,
 !!         35131 Padova, Italy
 !!
 !!    project:    ECOMAN
 !!    funded by:  ERC StG 758199 - NEWTON
 !!
 !!    ECOMAN is free software package: you can redistribute it and/or modify
 !!    it under the terms of the GNU General Public License as published
 !!    by the Free Software Foundation, version 3 of the License.
 !!
 !!    ECOMAN is distributed WITHOUT ANY WARRANTY; without even the implied
 !!    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 !!    See the GNU General Public License for more details.
 !!
 !!    You should have received a copy of the GNU General Public License
 !!    along with ECOMAN. If not, see <http://www.gnu.org/licenses/>.
 !!
 !!
 !!    Contact:
 !!        Manuele Faccenda    [manuele.faccenda@unipd.it]
 !!        Brandon VanderBeek  [brandon.vanderbeek@unipd.it]
 !!
 !!
 !!    Main development team:
 !!        Manuele Faccenda    [manuele.faccenda@unipd.it]
 !!        Brandon VanderBeek  [brandon.vanderbeek@unipd.it]
 !!        Albert de Montserrat Navarro
 !!        Jianfeng Yang
 !!
 !! ---------------------------------------------------------------------------
 !! ---------------------------------------------------------------------------
 !! ---------------------------------------------------------------------------

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! Module of common variables                                             !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   MODULE comvar

   INTEGER :: Tinit,Tend,Tstep,dimensions,cartspher,basicstag,x1periodic,x2periodic,x3periodic,yinyang
   INTEGER :: Lagrangian,uppermantlemod,rocktypemod,fsemod,fse3Dmod,fseminmod,fsemaxmod,TIaxismod,vpmaxmod,dvsmaxmod
   INTEGER :: Eulerian,vpvsmod,dvpvsmod,zoeppritzmod,radialmod,azimod,reflectmod,replicateZmod,specfem3Dmod,syntomomod
   DOUBLE PRECISION :: ln_fse_min,koef,cosx1,cosx2,cosx3,qhat(3),Incangle,pi,deg2rad
   DOUBLE PRECISION :: aziscalex1,aziscalex2,aziscalex3
   DOUBLE PRECISION :: dt,timesum
   ! File number and domain geometry

!!! Grid points of the domain where to interpolate the elastic tensors

   INTEGER :: nodenum,cellnum !! number of nodes,cells
   INTEGER :: nx1ref,nx3ref !! horizontal plane indexes for reference Vp, Vs, rho profile
   INTEGER :: nx11, nx21, nx31 !! Number of nodes of the velocity model
   DOUBLE PRECISION :: nstepx1, nstepx2, nstepx3
   DOUBLE PRECISION :: n1first,n2first,n3first,n1last,n2last,n3last
   !New Tomographic grid
   INTEGER :: nx1, nx2, nx3 !! Number of nodes of the Drex model
   DOUBLE PRECISION :: x10size, x20size, x30size
   DOUBLE PRECISION :: i1first,i2first,i3first,i1last,i2last,i3last
   DOUBLE PRECISION :: x1max,x2max,x3max
   !Old D-REX_S grid

   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: X1,X1n
   ! X grid points coordinates
   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: X2,X2n
   ! Y grid points coordinates
   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: X3,X3n
   ! Z grid points coordinates

!!! D-REX_S aggregates distribution and properties

   INTEGER :: marknum,marknum0 !! number of markers
   DOUBLE PRECISION :: mx1min,mx2min,mx3min
   DOUBLE PRECISION :: mx1max,mx2max,mx3max
   DOUBLE PRECISION :: mx1stp,mx2stp,mx3stp
   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: mx1
   ! X grid points coordinates
   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: mx2
   ! Y grid points coordinates
   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: mx3
   ! Z grid points coordinates
   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: ln_fse,amin,amed,amax
   ! finite strain = ln(longaxis/shortaxis)

   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: rho,mtk,mpgpa
   !Density, temperature, pressure,dummy rocktype
   INTEGER, DIMENSION(:), ALLOCATABLE :: rocktype,rt1,mYY
   !Rocktype

   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: epsnot
   DOUBLE PRECISION, DIMENSION(:,:,:), ALLOCATABLE :: l,e
   DOUBLE PRECISION, DIMENSION(:,:,:), ALLOCATABLE :: Fij,Rotm
   DOUBLE PRECISION, DIMENSION(:,:,:,:,:), ALLOCATABLE :: Ui,Ux
   DOUBLE PRECISION, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Dij

!!! Drex Parameters

   DOUBLE PRECISION, DIMENSION(5) :: top,bot
   DOUBLE PRECISION, DIMENSION(5) :: Xol,stressexp,lambda,Mob,chi,fractdislrock
   DOUBLE PRECISION, DIMENSION(5,12) :: tau
   ! Xol = fraction of anisotropic phase in the aggregate
   ! stressexp = stress exponent for non-Newtonian behavior
   ! lambda = nucleation parameter
   ! Mob = grain mobility
   ! threshold volume fraction for activation of grain boundary sliding
   ! tau = RSS for the slip systems of mineral phases

!!! Min/max Vp,dVs

   INTEGER degstp,nxy,nz
   DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: phix,phiy,phiz

!!! Elastic tensor

   DOUBLE PRECISION, DIMENSION(20,6,6) :: S0,dS0dp,dS0dp2,dS0dt,dS0dpt
   DOUBLE PRECISION, DIMENSION(6,6) :: dS0dp5,dS0dt5,mandel_scale
   INTEGER, DIMENSION(3,3) :: ijkl ! tensor of indices to form Cijkl from Sij
   INTEGER, DIMENSION(6) :: l1,l2 ! tensot of indices to form Sij from Cijkl
   DOUBLE PRECISION, DIMENSION (:,:,:), ALLOCATABLE :: Sav,Savn,Sav0
   DOUBLE PRECISION, DIMENSION (:), ALLOCATABLE :: Rhon,fsen
   DOUBLE PRECISION, DIMENSION (:), ALLOCATABLE :: Tk, Pa
   DOUBLE PRECISION ,DIMENSION(:,:), ALLOCATABLE :: X1save
   ! stiffness matrix
   INTEGER :: size3, size ! size = size3^3

!!! SPO parameters

   INTEGER :: spomod,ptmod,meltspomod,spograinmod,sporockmod,numminermax,numminer(5),rocknum=5
   DOUBLE PRECISION :: volfractrock(5),ro_back,ro_incl,phi_spo,etac1,volinc1
   CHARACTER(200) :: meltfilename
   INTEGER :: thetanum,phinum
   DOUBLE PRECISION :: Vstp,Vmax,stp,esa(3)
   DOUBLE PRECISION, DIMENSION (:), ALLOCATABLE :: thetaspo,phispo,meltmark
   DOUBLE PRECISION, DIMENSION(3,3) :: kron ! tensor of indices to form Cijkl from Sij
   DOUBLE PRECISION, DIMENSION(6,6) :: Cback,Cinc
   DOUBLE PRECISION, DIMENSION(3,3,3,3) :: Is,Id
   !Parameters set in inputspo.dat
   DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: AA,BB,CC,FF,LLL,NN,RRho
   !TI moduli f(P,T) and melt content

!!! Density,Vp,Vs thermodynamic databases

   INTEGER :: tnum,pnum,ptnum
   DOUBLE PRECISION, DIMENSION(:,:,:), ALLOCATABLE :: rhorock,vsrock,vprock,srock
   DOUBLE PRECISION, DIMENSION(:,:,:,:), ALLOCATABLE :: rhominer,vsminer,vpminer,volfractminer
   !HeFESTo

   INTEGER :: tknum,pbnum
   DOUBLE PRECISION :: tkmin,pbmin,tkstp,pbstp
   DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: td_rho
   !PERPLE_X

   END MODULE comvar

max_stars_repo_name: mfaccenda/ECOMAN

max_issues_repo_name: mfaccenda/ECOMAN

max_forks_repo_name: mfaccenda/ECOMAN


text:
      SUBROUTINE SETRVS (ST, ARR, NSZ)

C  setrvs initializes the real array ARR, based on the
C  value-representations in ST and also returns the number
C  of values in NSZ.

      CHARACTER ST*(*), STWK*700, TMPMSG*730
      INTEGER   NSZ, LST, NC, IERR
      REAL      ARR(*), RVAL

      NSZ = 0

C blank means zero entries
      IF (ST .EQ. ' ') RETURN

C get rid of leading, internal blanks
      CALL DEBLNK (ST, STWK, LST)

300   CONTINUE
C add trailing comma
      LST = LST+1
      STWK(LST:LST) = ','

C now sitting at alleged number
400   CONTINUE
C find next comma
      NC = INDEX(STWK, ',')
      IF (NC .LE. 1) THEN
         CALL UNMSG ('Adjacent commas passed to SETRVS.')
      ENDIF
C parse up to comma
      CALL PRSRL (STWK(1:NC-1), RVAL, IERR)
      IF (IERR .NE. 0) THEN
         TMPMSG = 'Invalid string sent to SETRVS: ' // ST
         CALL UNMSG (TMPMSG)
      ENDIF
      NSZ = NSZ+1
      ARR(NSZ) = RVAL
C delete thru comma
      STWK = STWK(NC+1:)
      IF (STWK .NE. ' ') GOTO 400

      END


text:
      SUBROUTINE OUTPSP
C
C     DEFINE OUTPUT VARIABLES FOR AE-C STUDY
C
      IMPLICIT REAL*8(A-H,O-Z)
      LOGICAL  FG1, FG2, FG3, FG4, FG5, INERF, RBLO, LEQU, LINIT(1)
      LOGICAL          NSTART, LRTAPE
      LOGICAL         LRUNGE , LTRNSI , LVDIV  , LEQUIV , LTRAN  ,
     *                LTRANV , LRATE  , LXDY   , LETA   , LTORQU ,
     *                LQFDOT , LDCT   , LANGLE , LSETUP , LSIMQ
C
C
      INTEGER
     * AWORK , CT1   , CT2   , CT3   , CT4   , CT5   , FCON  , PCON  ,
     * SCNDUM, SCN   , SCRDUM, SCR   , SFKDUM, SFK   , SFR   , SG    ,
     * SI    , SIG   , SIXDUM, SIX   , SKDUM , SK    , SL    , SLK   ,
     * SMA   , SMCDUM, SMC   , SMV   , SOK   , SPIDUM, SPI   , SQF   ,
     * SQL   , SR    , SSCN  , SSIX  , SVA   , SVB   , SVD   , SVI   ,
     * SVM   , SVP   , SVQ   , SXM   , SXT   , TORQ  , SMAL  , SEU   ,
     * SC    , SCG   , NFLXB , SFLX  , SFXM  , NMODS , SFCC  , SCC   ,
     * IINIT(1)      , IZINIT(1)     , SD    , SCXC(20)                   1
C
C
      REAL*8 LM(3,23),LMT(3)
      REAL*8
     * ANGD  (33)   , CNF  (3,10)  , ETIC  (3,10)  , ETMC  (3,10)   ,     2
     * FLQ   (3,20) , FLE  (3,3,20), FLH   (3,3,20),                      3
     * THADD ( 63)  , YMCD (3,2,11), RINIT (1)     , RZINIT(1)            4
C
C
      COMMON /CHEKS/           NSTART, LRTAPE
C
      COMMON /LDEBUG/ LRUNGE , LTRNSI , LVDIV  , LEQUIV , LTRAN  ,
     *                LTRANV , LRATE  , LXDY   , LETA   , LTORQU ,
     *                LQFDOT , LDCT   , LANGLE , LSETUP , LSIMQ
C
      COMMON /LOGIC/ FG1, FG2, FG3, FG4, FG5, INERF, RBLO(10)             5
C
C
      COMMON /INTG/    AWORK(200)   ,                                     6
     * CT1           , CT2           , CT3           , CT4           ,
     * CT5           , FCON  (33)    , JCON  (10)    , LCON  (22)    ,    7
     * MO    (10)    , NB1           , NBOD          , NCTC          ,    8
     * NFER          , NFKC          , NFRC          , NLOR          ,
     * NMV           , NMO           , NMOA          , NSVP          ,
     * NSVQ          , PCON  (11)    , SD            , SFR   (33)    ,    9
     * SG            , SI    ( 55)   , SIG           , SL            ,   10
     * SLK   (33)    , SMA   (10)    , SOK   (11)    , SQF   (11)    ,   11
     * SQL   (11)    , SMV           , SR            , SSCN          ,   12
     * SSIX          , SVA           , SVB           , SVD           ,
     * SVI           , SVM           , SVP   (22)    , SVQ   (33)    ,   13
     * SXM   (3,10)  , SXT           , TORQ  ( 97)   , SMAL          ,   14
     * SEU           , NTQ           , SC    (33)    , SCG           ,   15
     * NFLXB         , SFLX          , SFXM  (10)    , NMODS         ,   16
     * SFCC          , SCC   (10)                                        17
C
C
      COMMON /INTGZ/
     * SCNDUM        , SCN   ( 9)    , SCRDUM        , SCR   ( 9)    ,   18
     * SFKDUM        , SFK   ( 9)    , SIXDUM        , SIX   ( 9)    ,   19
     * SKDUM         , SK    ( 9)    , SPIDUM        , SPI   ( 9)    ,   20
     * SMCDUM        , SMC   ( 9)                                        21
C
C
      COMMON /REAL/
     * CA    (3,10)  , CAC   (3,10)  , CLM   (10)    , COMC  (3,11)  ,   22
     * DOMC  (3,11)  , ETC   (3,11)  , ETM   ( 63)   , FOMC  (3,11)  ,   23
     * GAM   (3, 66) , H             , HM    (3,10)  , HMC   (3,10)  ,   24
     * HMOM  (10)    , PHI   (3,11)  , PLM   (10)    , QF    (3,33)  ,   25
     * QFC   (3,33)  , QL    (3,22)  , QLC   (3,22)  , ROMC  (3,11)  ,   26
     * T             ,                 THA   ( 63)   , THAD  ( 63)   ,   27
     * THADW (10)    , THAW  (10)    , XDIC  (3,3, 66),XI    (3,3,10),   28
     * XIC   (3,3,10), XMAS  (10)    , XMN   ( 63, 63),XMT   (3,3,10),   29
     * TUG   (33)    , FLA   (3,20)  , FLB   (3,20)  , FLC   (3,20)  ,   30
     * FLD   (3,3,20), FLJ   (3,3,20), CAO   (3,10)  , XIO   (3,3,10),   31
     * FLIRC (3,10)  , FLCRC (3,10)  , FLAC  (3,20)  , FLQC  (3,20)  ,   32
     * FLOM  (20)    , ZETA  (20)    , FCF   (3,3,40), FCK   (3,40)  ,   33
     * TIMEND
C
C
      COMMON /REALZ/
     * CBDUM (1,3)    , CB    (3,10)  , CBCDUM(1,3)  , CBC    (3,10) ,   34
     * XMCDUM(1,1, 9) , XMC   (3,3,10), CBN(3)                           35
C
C
      COMMON/SATELL/
     *  GNAZ1  , TAZ1    ,TAZ2     , GNAZ4   , GNAZ5   , GNEL1  , TEL1 ,
     *  GNEL4  , GNEL5   , DIDLY   , PKSCT   , PT2     , PTS    , PTT  ,
     *  PTTS   , PKF     , PTF     , PKB     , PKA     , PKTV   , DELAY,
     *  CFSW   , DISWH   , PRNT    , BRATE   , WHELB   , DELC   ,
     *  SUN(3) , CONSV(3,6)        , SUNC(3) , SUN3(3) , SUND(3),
     *  SUN2(3), SUND2(3), SUNDD(3), EAZC    , EAZCD,
     *  SUND3(3)         , EAZ     , EAZD    , EEL     , EELD   , DIESV
C
      EQUIVALENCE (ETM(1),THADD(1))         ,(XMN(1,1),ANGD(1))    ,
     *            (XMN(1,3),YMCD(1,1,1))    ,(XMN(1,6),CNF(1,1))    ,
     *            (XMN(1,8),ETIC(1,1))      ,(XMN(1,10),ETMC(1,1))  ,
     *            (FLB(1,1),FLQ(1,1))       ,(FLE(1,1,1),FLD(1,1,1)),
     *            (FLH(1,1,1),FLJ(1,1,1))   ,
     *            (FG1,LINIT(1))            ,(CA(1,1),RINIT(1))     ,
     *            (CBDUM(1,1),RZINIT(1))    ,(AWORK(1),IINIT(1))    ,
     *            (SCNDUM,IZINIT(1))        ,(TORQ(78),SCXC(1))          78
C
      DIMENSION TEM1(3),TEM2(3),TEM3(3),DERV(3,11),TEM4(3),HBODY(3),
     *          VSV2(3),HINERT(3),PHII(3,3),TOMC(3,11),SYSCM(3),
     *          SYSIN(3,3),HB(3,10),TK(10),POS(3,10),VEL(3,10)
C
C
C
C
    1 CONTINUE
C
C
C     COMPUTE SYSTEM COMPOSITE CENTER OF MASS
      TOTM = 0.D0
      DO 11  I=1,3
   11 TEM1(I) = 0.D0
      DO 15  K=1,NBOD
      KO = KT0(NB1,0,K)
      CALL SCLV(XMAS(K),GAM(1,KO),TEM2)
      CALL VECADD(TEM1,TEM2,TEM1)
   15 TOTM = TOTM + XMAS(K)
      DO 16  I=1,3
   16 SYSCM(I) = TEM1(I)/TOTM
C
C
C     COMPUTE SYSTEM INERTIA TENSOR ABOUT COMPOSITE CENTER OF MASS
      CALL SUEOP(SYSCM,SYSCM,TOTM,SYSIN)
      DO 4  I=1,3
      DO 4  J=1,3
    4 SYSIN(I,J) = XDIC(I,J,1) - SYSIN(I,J)
C
C
C     COMPUTE INERTIAL ANGULAR MOMENTUM AND KINETIC ENERGY OF EACH
C       BODY AND OF THE COMPOSITE SYSTEM
      TKIN = 0.D0
      DO 7  I=1,3
      LMT(I) = 0.D0
    7 HBODY(I) = 0.D0
      DO 17 KKK=1,NBOD
      K=NBOD+1-KKK
      KK = K
      JK = JCON(K)
      IF(KK.NE.1) GO TO 28
      DO 29  I=1,3
   29 TEM1(I) = ROMC(I,NB1)
      GO TO 26
   28 CONTINUE
C     COMPUTE LINEAR VELOCITY OF CENTER OF MASS OF BODY K PUT IN TEM1
      IF(RBLO(K)) GO TO 19
      CALL VECROS(FOMC(1,JK),CAC(1,K),TEM1)
      CALL VECADD(ROMC(1,K),TEM1,TEM1)
      GO TO 24
   19 CALL VECROS(FOMC(1,K),CAC(1,K),TEM1)
   24 CALL VECADD(ROMC(1,NB1),TEM1,TEM1)
C     CHECK FOR END OF CHAIN
   25 IF(JK.EQ.0) GO TO 26
      CALL VECROS(FOMC(1,JK),CBC(1,KK),TEM2)
      CALL VECADD(TEM1,TEM2,TEM1)
      KK = JK
      JK = JCON(KK)
      GO TO 25
   26 CONTINUE
C
C     INTERTIAL POSITION OF CENTER OF MASS IN TEM2
      KL = KT0(NB1,0,K)
      CALL VECADD(CBC(1,1),GAM(1,KL),TEM2)
      DO 3  I=1,3
      POS(I,K) = TEM2(I)
    3 VEL(I,K) = TEM1(I)
C
C     START COMPUTATION OF ANGULAR MOMENTUM, LINEAR MOMENTUM AND KINETIC
C     ENERGY
      CALL DYDOTV(XIC(1,1,K),FOMC(1,K),HB(1,K))
      CALL VECDOT(FOMC(1,K),HB(1,K),TK(K))
      CALL VECDOT(TEM1,TEM1,TEM)
      TK(K) = .5D0*(TK(K) + XMAS(K)*TEM)
      CALL VECROS(TEM2,TEM1,TEM3)
      CALL SCLV(XMAS(K),TEM3,TEM3)
      CALL VECADD(HB(1,K),TEM3,HB(1,K))
      IF(.NOT.RBLO(K)) GO TO 32
      IF(NMO.EQ.0) GO TO 32
      DO 27  M=1,NMO
      IF(MO(M).NE.K) GO TO 27
      CALL SCLV(HMOM(M),HMC(1,M),TEM3)
      CALL VECADD(HB(1,K),TEM3,HB(1,K))
      TK(K) = TK(K) + .5D0*HMOM(M)**2/PLM(M)
   27 CONTINUE
   32 CONTINUE
C
C     ADD UP FOR SYSTEM ANGULAR MOMENTUM AND KINETIC ENERGY
      TKIN = TKIN + TK(K)
      CALL VECADD(HB(1,K),HBODY,HBODY)
      CALL SCLV(XMAS(K),VEL(1,K),LM(1,K))
      CALL VECADD(LMT,LM(1,K),LMT)
   17 CONTINUE
      CALL TRNSPS(XMC(1,1,0))
      CALL VECTRN(HBODY,XMC(1,1,0),HINERT)
      CALL TRNSPS(XMC(1,1,0))
      IF(.NOT.INERF) GO TO 2
      CALL TRNSPS(XMC(1,1,1))
      CALL VECTRN(HINERT,XMC(1,1,1),HBODY)
      CALL TRNSPS(XMC(1,1,1))
    2 CONTINUE
      HMG = DSQRT(HBODY(1)**2+HBODY(2)**2+HBODY(3)**2)
      A   = DSQRT(HBODY(1)**2+HBODY(2)**2)
      ANUTAT = DASIN(A/HMG)
C
C
C     COMPUTE INERTIAL ACCELERATIONS
      DO 8  I=1,3
    8 TOMC(I,1) = DOMC(I,1)
      IF(NBOD.EQ.1) GO TO 31
      DO 14  K=2,NBOD
      CALL VECROS(FOMC(1,K),ROMC(1,K),TEM1)
   14 CALL VECSUB(DOMC(1,K),TEM1,TOMC(1,K))
   31 CONTINUE
      CALL VECROS(FOMC(1,1),ROMC(1,NB1),TEM1)
      CALL VECSUB(DOMC(1,NB1),TEM1,TOMC(1,NB1))
      M = 1
      DO 20  K=1,NB1
      IF(K.EQ.1) GO TO 21
      M = M+3-PCON(K-1)
   21 DO 22  I=1,3
   22 TEM1(I) = 0
      IF(PCON(K).EQ.3) GO TO 30
      MTRM = M+2-PCON(K)
      DO 23 MM=M,MTRM
      CALL SCLV(THADD(MM),QFC(1,MM),TEM2)
   23 CALL VECADD(TEM1,TEM2,TEM1)
   30 CONTINUE
   20 CALL VECADD(TEM1,TOMC(1,K),DERV(1,K))
C
C
      IF(T.NE.0.D0) GO TO 9
      PRINT 200
      PRINT 201
      PRINT 202
      PRINT 203
      PRINT 204
      PRINT 210
      PRINT 211
    9 PRINT 205
  205 FORMAT ('   ')
      WRITE(11,307)  T,HMG,TKIN,(FOMC(I,1),I=1,3),(SUN3(I),I=1,3),ANUTAT
      PRINT 207   , T,HMG,TKIN,(FOMC(I,1),I=1,3),(SUN3(I),I=1,3),ANUTAT
      WRITE(11,307)  (THA(I),THAD(I),I=1,3),EAZ,EAZD,EEL,EELD
      PRINT 207   , (THA(I),THAD(I),I=1,3),EAZ,EAZD,EEL,EELD
      WRITE(11,308)  (CONSV(2,I),I=1,6),THA(4),THAD(4)
      PRINT 208   , (CONSV(2,I),I=1,6),THA(4),THAD(4)
      WRITE(11,308)  (CONSV(3,I),I=1,6),THA(5),THAD(5)
      PRINT 208   , (CONSV(3,I),I=1,6),THA(5),THAD(5)
      ISWH = DISWH + .1D-05
      WRITE(11,309)  (CONSV(1,I),I=1,6),THADW(1),ISWH
      PRINT 209   , (CONSV(1,I),I=1,6),THADW(1),ISWH
      WRITE(11,306) (SUND(I),I=1,3),(SUN3(I),I=1,3),(SUND3(I),I=1,3)
      PRINT 206,    (SUND(I),I=1,3),(SUN3(I),I=1,3),(SUND3(I),I=1,3)
      WRITE(11,308) (SUN2(I),I=1,3),(SUNDD(I),I=1,3),EAZC,EAZCD
      PRINT 208,    (SUN2(I),I=1,3),(SUNDD(I),I=1,3),EAZC,EAZCD
  206 FORMAT (1X,9D13.6)
  306 FORMAT (1P9D13.5)
  207 FORMAT (1X,10D13.6)
  307 FORMAT (1P10D13.5)
  208 FORMAT (1X,8D13.6)
  308 FORMAT (1P8D13.5)
  209 FORMAT (1X,7D13.6,I13)
  309 FORMAT (1P7D13.5,I13)
  200 FORMAT ('            T          HMG         TKIN      FOMC(1)
     * FOMC(2)      FOMC(3)      SUN3(1)      SUN3(2)      SUN3(3)
     * ANUTAT ')
  201 FORMAT ('       THA(1)      THAD(1)       THA(2)      THAD(2)
     *  THA(3)      THAD(3)          EAZ         EAZD          EEL
     *   EELD ')
  202 FORMAT (' AZIMUTH-  U2           U4           U5           U6
     *      U7          U10       THA(4)      THAD(4) ')
  203 FORMAT (' ELEVATION-U2           U3           U5        TQ(4)
     *      U7          U10       THA(5)      THAD(5) ')
  204 FORMAT (' PITCH-    U2        TQ(1)           U5           U7
     *      U8          U10     THADW(1)         ISWH  ')
  210 FORMAT ('      SUND(1)      SUND(2)      SUND(3)      SUN3(1)
     * SUN3(2)      SUN3(3)     SUND3(1)     SUND3(2)     SUND3(3)  ')
  211 FORMAT ('      SUN2(1)      SUN2(2)      SUN2(3)     SUNDD(1)
     *SUNDD(2)     SUNDD(3)         EAZC        EAZCD ')
      RETURN
      END

ext: for


!Main part of the program. Contains: loop for simulation and two subroutines for printing information during simulation.

program project5_main
      use dynamics_mod
      integer::i
      real(rk)::sim_time

      !Initialization of simulation information and files
      call read_input()
      call clear_output()

      !Starting information, sim_time is used to keep track of time.
      print "(a)","Initial positions:"
      call pos_info()
      sim_time=0.0

      !Simulation loop
      do i=1, int(instr(3))
        call update_sys()
        sim_time=sim_time+instr(1)

        !Check for info or write
        if(mod(i,int(instr(5)))==0) then
                call write_data(sim_time)
        end if
        if(mod(i,int(instr(4)))==0) then
                call info(i)
        end if
      end do
      print "(a)", "-----"

      !Final information
      print "(a)","Final positions:"
      call pos_info()

contains
        !Subroutine for printing the required information
        subroutine info(step)
                implicit none
                integer,intent(in)::step
                integer::j
                print "(a)", "-----"
                print "(a,i0)", "Number of objects: ",size(system)
                print "(a,f7.1,a)", "Time from the beginning of simulation: ",step*instr(1)/60/60/24," days"
                print "(a,i0)", "Number of steps from the beginning of simulation: ", step
                print "(a,i0)", "Number of steps written to file: ", int(step/instr(5))
                print "(a)", "Positions of objects (meters from origin):"
                call pos_info()
         end subroutine info

         !Subroutine for getting the positions of the objects
         subroutine pos_info()
                 implicit none
                 integer::k
                 do k=1, size(system)
                        print "(a,3ES18.5)", trim(system(k)%description), system(k)%pos
                end do
         end subroutine pos_info
end program


text:
!Issue number DPD200237118
!!
!! SELECTOR IN SELECT-TYPE NOT RECOGNIZED AS POLYMORPHIC
!!
!! In the following example a (type-bound) function returning a pointer to an
!! unlimited polymorphic variable is used as the selector in a SELECT TYPE
!! construct.  When the function is invoked directly, the Intel 13.0.0 compiler
!! correctly recognizes the selector as being polymorphic.  But when the
!! function is invoked through an object, the compiler fails to recognize it
!! as polymorphic, which is incorrect.
!!
!! % ifort --version
!! ifort (IFORT) 13.0.0 20120731
!!
!! % ifort -c intel-bug-20121006a-fixed.f90
!!intel-bug-20121006a-fixed.f90(52): error #8247: Selector in SELECT TYPE statements must be polymorphic value.
!!  select type (uptr => foo%return_uptr())
!!--^
!!compilation aborted for intel-bug-20121006a-fixed.f90 (code 1)
!!

module typeA_def

  type :: typeA
    class(*), pointer :: uptr => null()
  contains
    procedure :: return_uptr
  end type

contains

  function return_uptr (this) result (uptr)
    class(typeA) :: this
    class(*), pointer :: uptr
    uptr => this%uptr
  end function

end module

program main

  use typeA_def
  type(typeA) :: foo

  !! SELECTOR IS CORRECTLY RECOGNIZED AS POLYMORPHIC
  select type (uptr => return_uptr(foo))
  class is (typeA)
  end select

  !! SELECTOR IS NOT RECOGNIZED AS POLYMORPHIC -- WRONG.
  select type (uptr => foo%return_uptr())
  class is (typeA)
  end select

end program

max_stars_repo_name: dhnza/fortran-compiler-tests

max_issues_repo_name: dhnza/fortran-compiler-tests

max_forks_repo_name: dhnza/fortran-compiler-tests


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:34:09 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE CO__genmod
          INTERFACE
            SUBROUTINE CO(TV,MLDPK)
              REAL(KIND=8) :: TV(14,0:37,0:37,0:33)
              INTEGER(KIND=4) :: MLDPK(2,36,36)
            END SUBROUTINE CO
          END INTERFACE
        END MODULE CO__genmod