text:
      PROGRAM FM829

C***********************************************************************00010829
C*****  FORTRAN 77                                                      00020829
C*****   FM829                                                          00030829
C*****                       YGEN1 - (206)                              00040829
C*****                                                                  00050829
C***********************************************************************00060829
C*****  TESTING OF GENERIC FUNCTIONS                            ANS REF 00070829
C*****          INT, REAL, DBLE, CMPLX                           15.3   00080829
C*****                                                          TABLE 5 00090829
CBB** ********************** BBCCOMNT **********************************00100829
C****                                                                   00110829
C****            1978 FORTRAN COMPILER VALIDATION SYSTEM                00120829
C****                          VERSION 2.1                              00130829
C****                                                                   00140829
C****                                                                   00150829
C****           SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO         00160829
C****          NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY           00170829
C****               SOFTWARE STANDARDS VALIDATION GROUP                 00180829
C****                      BUILDING 225  RM A266                        00190829
C****                     GAITHERSBURG, MD  20899                       00200829
C****                                                                   00210829
C****                                                                   00220829
C****                                                                   00230829
CBE** ********************** BBCCOMNT **********************************00240829
C*****                                                                  00250829
C*****  S P E C I F I C A T I O N S  SEGMENT 206                        00260829
        DOUBLE PRECISION AVD, BVD, CVD, DVCORR                          00270829
        COMPLEX AVC, BVC, CVC, ZVCORR                                   00280829
        REAL R2E(2)                                                     00290829
        EQUIVALENCE (BVC, R2E)                                          00300829
C*****                                                                  00310829
CBB** ********************** BBCINITA **********************************00320829
C**** SPECIFICATION STATEMENTS                                          00330829
C****                                                                   00340829
      CHARACTER ZVERS*13, ZVERSD*17, ZDATE*17, ZPROG*5, ZCOMPL*20,      00350829
     1          ZNAME*20, ZTAPE*10, ZPROJ*13, REMRKS*31, ZTAPED*13      00360829
CBE** ********************** BBCINITA **********************************00370829
CBB** ********************** BBCINITB **********************************00380829
C**** INITIALIZE SECTION                                                00390829
      DATA  ZVERS,                  ZVERSD,             ZDATE           00400829
     1      /'VERSION 2.1  ',  '93/10/21*21.02.00',  '*NO DATE*TIME'/   00410829
      DATA       ZCOMPL,             ZNAME,             ZTAPE           00420829
     1      /'*NONE SPECIFIED*', '*NO COMPANY NAME*', '*NO TAPE*'/      00430829
      DATA       ZPROJ,           ZTAPED,         ZPROG                 00440829
     1      /'*NO PROJECT*',   '*NO TAPE DATE',  'XXXXX'/               00450829
      DATA   REMRKS /'                               '/                 00460829
C**** THE FOLLOWING 9 COMMENT LINES (CZ01, CZ02, ...) CAN BE REPLACED   00470829
C**** FOR IDENTIFYING THE TEST ENVIRONMENT                              00480829
C****                                                                   00490829
CZ01  ZVERS  = 'VERSION OF THE COMPILER VALIDATION SYSTEM'              00500829
CZ02  ZVERSD = 'CREATION DATE/TIME OF THE COMPILER VALIDATION SYSTEM'   00510829
CZ03  ZPROG  = 'PROGRAM NAME'                                           00520829
CZ04  ZDATE  = 'DATE OF TEST'                                           00530829
CZ05  ZCOMPL = 'COMPILER IDENTIFICATION'                                00540829
CZ06  ZPROJ  = 'PROJECT NUMBER/IDENTIFICATION'                          00550829
CZ07  ZNAME  = 'NAME OF USER'                                           00560829
CZ08  ZTAPE  = 'TAPE OWNER/ID'                                          00570829
CZ09  ZTAPED = 'DATE TAPE COPIED'                                       00580829
C                                                                       00590829
      IVPASS = 0                                                        00600829
      IVFAIL = 0                                                        00610829
      IVDELE = 0                                                        00620829
      IVINSP = 0                                                        00630829
      IVTOTL = 0                                                        00640829
      IVTOTN = 0                                                        00650829
      ICZERO = 0                                                        00660829
C                                                                       00670829
C     I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER.         00680829
      I01 = 05                                                          00690829
C     I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER.             00700829
      I02 = 06                                                          00710829
C                                                                       00720829
CX010   REPLACED BY FEXEC X-010 CONTROL CARD (CARD-READER UNIT NUMBER). 00730829
C     THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5      00740829
CX011   REPLACED BY FEXEC X-011 CONTROL CARD.  CX011 IS FOR SYSTEMS     00750829
C     REQUIRING ADDITIONAL STATEMENTS FOR FILES ASSOCIATED WITH CX010.  00760829
C                                                                       00770829
CX020   REPLACED BY FEXEC X-020 CONTROL CARD (PRINTER UNIT NUMBER).     00780829
C     THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02= 6       00790829
CX021   REPLACED BY FEXEC X-021 CONTROL CARD.  CX021 IS FOR SYSTEMS     00800829
C     REQUIRING ADDITIONAL STATEMENTS FOR FILES ASSOCIATED WITH CX020.  00810829
C                                                                       00820829
CBE** ********************** BBCINITB **********************************00830829
      NUVI = I02                                                        00840829
      IVTOTL = 35                                                       00850829
      ZPROG = 'FM829'                                                   00860829
CBB** ********************** BBCHED0A **********************************00870829
C****                                                                   00880829
C**** WRITE REPORT TITLE                                                00890829
C****                                                                   00900829
      WRITE (I02, 90002)                                                00910829
      WRITE (I02, 90006)                                                00920829
      WRITE (I02, 90007)                                                00930829
      WRITE (I02, 90008)  ZVERS, ZVERSD                                 00940829
      WRITE (I02, 90009)  ZPROG, ZPROG                                  00950829
      WRITE (I02, 90010)  ZDATE, ZCOMPL                                 00960829
CBE** ********************** BBCHED0A **********************************00970829
C*****                                                                  00980829
C*****    HEADER FOR SEGMENT 206                                        00990829
        WRITE(NUVI,20600)                                               01000829
20600   FORMAT( " ", /  " YGEN1 - (206) GENERIC FUNCTIONS --" //        01010829
     1          "  INT, REAL, DBLE, CMPLX" //                           01020829
     2          "  ANS REF. - 15.3" )                                   01030829
CBB** ********************** BBCHED0B **********************************01040829
C**** WRITE DETAIL REPORT HEADERS                                       01050829
C****                                                                   01060829
      WRITE (I02,90004)                                                 01070829
      WRITE (I02,90004)                                                 01080829
      WRITE (I02,90013)                                                 01090829
      WRITE (I02,90014)                                                 01100829
      WRITE (I02,90015) IVTOTL                                          01110829
CBE** ********************** BBCHED0B **********************************01120829
C*****                                                                  01130829
CT001*  TEST 1                          TEST OF INT                     01140829
C*****                                          WITH INTEGER ARG        01150829
           IVTNUM = 1                                                   01160829
        LVI = INT(485)                                                  01170829
           IF (LVI -   485) 20010, 10010, 20010                         01180829
10010      IVPASS = IVPASS + 1                                          01190829
           WRITE (NUVI, 80002) IVTNUM                                   01200829
           GO TO 0011                                                   01210829
20010      IVFAIL = IVFAIL + 1                                          01220829
           IVCORR =   485                                               01230829
           WRITE (NUVI, 80010) IVTNUM, LVI, IVCORR                      01240829
 0011      CONTINUE                                                     01250829
CT002*  TEST 2                                  WITH DOUBLE PREC ARG    01260829
           IVTNUM = 2                                                   01270829
        LVI = INT(1.375D0)                                              01280829
           IF (LVI -     1) 20020, 10020, 20020                         01290829
10020      IVPASS = IVPASS + 1                                          01300829
           WRITE (NUVI, 80002) IVTNUM                                   01310829
           GO TO 0021                                                   01320829
20020      IVFAIL = IVFAIL + 1                                          01330829
           IVCORR =     1                                               01340829
           WRITE (NUVI, 80010) IVTNUM, LVI, IVCORR                      01350829
 0021      CONTINUE                                                     01360829
CT003*  TEST 3                                  WITH COMPLEX ARG        01370829
           IVTNUM = 3                                                   01380829
        LVI = INT((1.24, 5.67))                                         01390829
           IF (LVI -     1) 20030, 10030, 20030                         01400829
10030      IVPASS = IVPASS + 1                                          01410829
           WRITE (NUVI, 80002) IVTNUM                                   01420829
           GO TO 0031                                                   01430829
20030      IVFAIL = IVFAIL + 1                                          01440829
           IVCORR =     1                                               01450829
           WRITE (NUVI, 80010) IVTNUM, LVI, IVCORR                      01460829
 0031      CONTINUE                                                     01470829
CT004*  TEST 4                          TEST OF INT AND IFIX            01480829
C*****                                          WITH REAL ARGS          01490829
           IVTNUM = 4                                                   01500829
        LVI = INT(6.0001) + IFIX(-1.750)                                01510829
           IF (LVI -     5) 20040, 10040, 20040                         01520829
10040      IVPASS = IVPASS + 1                                          01530829
           WRITE (NUVI, 80002) IVTNUM                                   01540829
           GO TO 0041                                                   01550829
20040      IVFAIL = IVFAIL + 1                                          01560829
           IVCORR =     5                                               01570829
           WRITE (NUVI, 80010) IVTNUM, LVI, IVCORR                      01580829
 0041      CONTINUE                                                     01590829
CT005*  TEST 5                          TEST OF INT AND IDINT           01600829
C*****                                          WITH DOUBLE PREC ARGS   01610829
           IVTNUM = 5                                                   01620829
        AVD = -1.11D1                                                   01630829
        LVI = INT(AVD) * IDINT(3.5D0)                                   01640829
           IF (LVI +    33) 20050, 10050, 20050                         01650829
10050      IVPASS = IVPASS + 1                                          01660829
           WRITE (NUVI, 80002) IVTNUM                                   01670829
           GO TO 0051                                                   01680829
20050      IVFAIL = IVFAIL + 1                                          01690829
           IVCORR =   -33                                               01700829
           WRITE (NUVI, 80010) IVTNUM, LVI, IVCORR                      01710829
 0051      CONTINUE                                                     01720829
CT006*  TEST 6             INTEGER, REAL, DOUBLE PRECISION, AND COMPLEX 01730829
C*****                                                        ARGUMENTS 01740829
           IVTNUM = 6                                                   01750829
        LVI = INT(-327) + INT(6.75) * INT(123) - INT(6.0001D0)          01760829
     1        / IFIX(13.3) + INT((2.4, 3.5)) + IDINT(-3.375D0)          01770829
           IF (LVI -   410) 20060, 10060, 20060                         01780829
10060      IVPASS = IVPASS + 1                                          01790829
           WRITE (NUVI, 80002) IVTNUM                                   01800829
           GO TO 0061                                                   01810829
20060      IVFAIL = IVFAIL + 1                                          01820829
           IVCORR =   410                                               01830829
           WRITE (NUVI, 80010) IVTNUM, LVI, IVCORR                      01840829
 0061      CONTINUE                                                     01850829
CT007*  TEST 7                          TEST OF REAL                    01860829
C*****                                          WITH REAL ARG           01870829
           IVTNUM = 7                                                   01880829
        AVS = -3.0                                                      01890829
        BVS = REAL(AVS)                                                 01900829
           IF (BVS +  0.30002E+01) 20070, 10070, 40070                  01910829
40070      IF (BVS +  0.29998E+01) 10070, 10070, 20070                  01920829
10070      IVPASS = IVPASS + 1                                          01930829
           WRITE (NUVI, 80002) IVTNUM                                   01940829
           GO TO 0071                                                   01950829
20070      IVFAIL = IVFAIL + 1                                          01960829
           RVCORR = -3.0                                                01970829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      01980829
 0071      CONTINUE                                                     01990829
CT008*  TEST 8                                  WITH DOUBLE PRECISION   02000829
           IVTNUM = 8                                                   02010829
        AVD = 0.96875D0                                                 02020829
        BVS = REAL(AVD)                                                 02030829
           IF (BVS -  0.96870E+00) 20080, 10080, 40080                  02040829
40080      IF (BVS -  0.96880E+00) 10080, 10080, 20080                  02050829
10080      IVPASS = IVPASS + 1                                          02060829
           WRITE (NUVI, 80002) IVTNUM                                   02070829
           GO TO 0081                                                   02080829
20080      IVFAIL = IVFAIL + 1                                          02090829
           RVCORR = 0.96875                                             02100829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      02110829
 0081      CONTINUE                                                     02120829
CT009*  TEST 9                                  WITH COMPLEX            02130829
           IVTNUM = 9                                                   02140829
        BVS = REAL((2.5, -3.0))                                         02150829
           IF (BVS -  0.24998E+01) 20090, 10090, 40090                  02160829
40090      IF (BVS -  0.25002E+01) 10090, 10090, 20090                  02170829
10090      IVPASS = IVPASS + 1                                          02180829
           WRITE (NUVI, 80002) IVTNUM                                   02190829
           GO TO 0091                                                   02200829
20090      IVFAIL = IVFAIL + 1                                          02210829
           RVCORR = 2.5                                                 02220829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      02230829
 0091      CONTINUE                                                     02240829
CT010*  TEST 10                         TEST OF REAL AND FLOAT          02250829
           IVTNUM = 10                                                  02260829
        BVS = REAL(6) + FLOAT(8)                                        02270829
           IF (BVS -  0.13999E+02) 20100, 10100, 40100                  02280829
40100      IF (BVS -  0.14001E+02) 10100, 10100, 20100                  02290829
10100      IVPASS = IVPASS + 1                                          02300829
           WRITE (NUVI, 80002) IVTNUM                                   02310829
           GO TO 0101                                                   02320829
20100      IVFAIL = IVFAIL + 1                                          02330829
           RVCORR = 14.0                                                02340829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      02350829
 0101      CONTINUE                                                     02360829
CT011*  TEST 11                         TEST OF REAL AND SNGL           02370829
           IVTNUM = 11                                                  02380829
        AVD = 2.5D0                                                     02390829
        BVS = REAL(AVD) + SNGL(0.35875D2)                               02400829
           IF (BVS -  0.38373E+02) 20110, 10110, 40110                  02410829
40110      IF (BVS -  0.38377E+02) 10110, 10110, 20110                  02420829
10110      IVPASS = IVPASS + 1                                          02430829
           WRITE (NUVI, 80002) IVTNUM                                   02440829
           GO TO 0111                                                   02450829
20110      IVFAIL = IVFAIL + 1                                          02460829
           RVCORR = 38.375                                              02470829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      02480829
 0111      CONTINUE                                                     02490829
CT012*  TEST 12                         TEST OF REAL, FLOAT, AND SNGL   02500829
           IVTNUM = 12                                                  02510829
        BVS = REAL(13) + FLOAT(9) * SNGL(0.7625D1) - REAL(2.625D0) +    02520829
     1          REAL(3.5) / REAL((2.0, 4.0))                            02530829
           IF (BVS -  0.80746E+02) 20120, 10120, 40120                  02540829
40120      IF (BVS -  0.80754E+02) 10120, 10120, 20120                  02550829
10120      IVPASS = IVPASS + 1                                          02560829
           WRITE (NUVI, 80002) IVTNUM                                   02570829
           GO TO 0121                                                   02580829
20120      IVFAIL = IVFAIL + 1                                          02590829
           RVCORR = 80.75                                               02600829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      02610829
 0121      CONTINUE                                                     02620829
CT013*  TEST 13                         TEST OF DBLE                    02630829
C*****                                          WITH INTEGER ARG        02640829
           IVTNUM = 13                                                  02650829
        LVI = 9                                                         02660829
        BVD = DBLE(LVI)                                                 02670829
           IF (BVD -  0.89995D+01) 20130, 10130, 40130                  02680829
40130      IF (BVD -  0.90005D+01) 10130, 10130, 20130                  02690829
10130      IVPASS = IVPASS + 1                                          02700829
           WRITE (NUVI, 80002) IVTNUM                                   02710829
           GO TO 0131                                                   02720829
20130      IVFAIL = IVFAIL + 1                                          02730829
           DVCORR = 9.0D0                                               02740829
           WRITE (NUVI, 80031) IVTNUM, BVD, DVCORR                      02750829
 0131      CONTINUE                                                     02760829
CT014*  TEST 14                                 WITH REAL ARG           02770829
           IVTNUM = 14                                                  02780829
        AVS = 10.5                                                      02790829
        BVD = DBLE(AVS)                                                 02800829
           IF (BVD -  0.10499D+02) 20140, 10140, 40140                  02810829
40140      IF (BVD -  0.10501D+02) 10140, 10140, 20140                  02820829
10140      IVPASS = IVPASS + 1                                          02830829
           WRITE (NUVI, 80002) IVTNUM                                   02840829
           GO TO 0141                                                   02850829
20140      IVFAIL = IVFAIL + 1                                          02860829
           DVCORR = 10.5D0                                              02870829
           WRITE (NUVI, 80031) IVTNUM, BVD, DVCORR                      02880829
 0141      CONTINUE                                                     02890829
CT015*  TEST 15                                 WITH DOUBLE PREC ARG    02900829
           IVTNUM = 15                                                  02910829
        AVD = 9.9D0                                                     02920829
        BVD = DBLE(AVD)                                                 02930829
           IF (BVD -  0.9899999995D+01) 20150, 10150, 40150             02940829
40150      IF (BVD -  0.9900000005D+01) 10150, 10150, 20150             02950829
10150      IVPASS = IVPASS + 1                                          02960829
           WRITE (NUVI, 80002) IVTNUM                                   02970829
           GO TO 0151                                                   02980829
20150      IVFAIL = IVFAIL + 1                                          02990829
           DVCORR = 9.9D0                                               03000829
           WRITE (NUVI, 80031) IVTNUM, BVD, DVCORR                      03010829
 0151      CONTINUE                                                     03020829
CT016*  TEST 16                                 WITH COMPLEX ARG        03030829
           IVTNUM = 16                                                  03040829
        AVC = (2.5, 5.5)                                                03050829
        BVD = DBLE(AVC)                                                 03060829
           IF (BVD -  0.24998D+01) 20160, 10160, 40160                  03070829
40160      IF (BVD -  0.25002D+01) 10160, 10160, 20160                  03080829
10160      IVPASS = IVPASS + 1                                          03090829
           WRITE (NUVI, 80002) IVTNUM                                   03100829
           GO TO 0161                                                   03110829
20160      IVFAIL = IVFAIL + 1                                          03120829
           DVCORR = 2.5D0                                               03130829
           WRITE (NUVI, 80031) IVTNUM, BVD, DVCORR                      03140829
 0161      CONTINUE                                                     03150829
CT017*  TEST 17                         TEST OF CMPLX WITH ONE ARG      03160829
C*****                                          WITH INTEGER ARG        03170829
           IVTNUM = 17                                                  03180829
        BVC = CMPLX(9)                                                  03190829
           IF (R2E(1) -  0.89995E+01) 20170, 40172, 40171               03200829
40171      IF (R2E(1) -  0.90005E+01) 40172, 40172, 20170               03210829
40172      IF (R2E(2) +  0.50000E-04) 20170, 10170, 40170               03220829
40170      IF (R2E(2) -  0.50000E-04) 10170, 10170, 20170               03230829
10170      IVPASS = IVPASS + 1                                          03240829
           WRITE (NUVI, 80002) IVTNUM                                   03250829
           GO TO 0171                                                   03260829
20170      IVFAIL = IVFAIL + 1                                          03270829
           ZVCORR = (9,0)                                               03280829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      03290829
 0171      CONTINUE                                                     03300829
CT018*  TEST 18                                 WITH REAL               03310829
           IVTNUM = 18                                                  03320829
        BVC = CMPLX(4.093)                                              03330829
           IF (R2E(1) -  0.40928E+01) 20180, 40182, 40181               03340829
40181      IF (R2E(1) -  0.40932E+01) 40182, 40182, 20180               03350829
40182      IF (R2E(2) +  0.50000E-04) 20180, 10180, 40180               03360829
40180      IF (R2E(2) -  0.50000E-04) 10180, 10180, 20180               03370829
10180      IVPASS = IVPASS + 1                                          03380829
           WRITE (NUVI, 80002) IVTNUM                                   03390829
           GO TO 0181                                                   03400829
20180      IVFAIL = IVFAIL + 1                                          03410829
           ZVCORR = (4.093,0.0)                                         03420829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      03430829
 0181      CONTINUE                                                     03440829
CT019*  TEST 19                                 WITH DOUBLE PREC ARG    03450829
           IVTNUM = 19                                                  03460829
        AVD = 0.375D-3                                                  03470829
        BVC = CMPLX(AVD)                                                03480829
           IF (R2E(1) -  0.37498E-03) 20190, 40192, 40191               03490829
40191      IF (R2E(1) -  0.37502E-03) 40192, 40192, 20190               03500829
40192      IF (R2E(2) +  0.50000E-04) 20190, 10190, 40190               03510829
40190      IF (R2E(2) -  0.50000E-04) 10190, 10190, 20190               03520829
10190      IVPASS = IVPASS + 1                                          03530829
           WRITE (NUVI, 80002) IVTNUM                                   03540829
           GO TO 0191                                                   03550829
20190      IVFAIL = IVFAIL + 1                                          03560829
           ZVCORR = (0.375E-3, 0.0E0)                                   03570829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      03580829
 0191      CONTINUE                                                     03590829
CT020*  TEST 20                                 WITH COMPLEX            03600829
           IVTNUM = 20                                                  03610829
        AVC = (4.5, 1.2)                                                03620829
        BVC = CMPLX(AVC)                                                03630829
           IF (R2E(1) -  0.44997E+01) 20200, 40202, 40201               03640829
40201      IF (R2E(1) -  0.45003E+01) 40202, 40202, 20200               03650829
40202      IF (R2E(2) -  0.11999E+01) 20200, 10200, 40200               03660829
40200      IF (R2E(2) -  0.12001E+01) 10200, 10200, 20200               03670829
10200      IVPASS = IVPASS + 1                                          03680829
           WRITE (NUVI, 80002) IVTNUM                                   03690829
           GO TO 0201                                                   03700829
20200      IVFAIL = IVFAIL + 1                                          03710829
           ZVCORR = (4.5, 1.2)                                          03720829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      03730829
 0201      CONTINUE                                                     03740829
CT021*  TEST 21                         TEST OF CMPLX WITH TWO ARGS     03750829
C*****                                          WITH INTEGER ARGS       03760829
           IVTNUM = 21                                                  03770829
        BVC = CMPLX(3, 1)                                               03780829
           IF (R2E(1) -  0.29998E+01) 20210, 40212, 40211               03790829
40211      IF (R2E(1) -  0.30002E+01) 40212, 40212, 20210               03800829
40212      IF (R2E(2) -  0.99995E+00) 20210, 10210, 40210               03810829
40210      IF (R2E(2) -  0.10001E+01) 10210, 10210, 20210               03820829
10210      IVPASS = IVPASS + 1                                          03830829
           WRITE (NUVI, 80002) IVTNUM                                   03840829
           GO TO 0211                                                   03850829
20210      IVFAIL = IVFAIL + 1                                          03860829
           ZVCORR = (3.0, 1.0)                                          03870829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      03880829
 0211      CONTINUE                                                     03890829
CT022*  TEST 22                                 WITH REAL ARGS          03900829
           IVTNUM = 22                                                  03910829
        BVC = CMPLX(8.34, 634.3)                                        03920829
           IF (R2E(1) -  0.83395E+01) 20220, 40222, 40221               03930829
40221      IF (R2E(1) -  0.83405E+01) 40222, 40222, 20220               03940829
40222      IF (R2E(2) -  0.63426E+03) 20220, 10220, 40220               03950829
40220      IF (R2E(2) -  0.63434E+03) 10220, 10220, 20220               03960829
10220      IVPASS = IVPASS + 1                                          03970829
           WRITE (NUVI, 80002) IVTNUM                                   03980829
           GO TO 0221                                                   03990829
20220      IVFAIL = IVFAIL + 1                                          04000829
           ZVCORR = (8.34, 634.3)                                       04010829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      04020829
 0221      CONTINUE                                                     04030829
CT023*  TEST 23                                 WITH DOUBLE PREC ARGS   04040829
           IVTNUM = 23                                                  04050829
        AVD = 0.96875D0                                                 04060829
        BVD = 3.5D-1                                                    04070829
        BVC = CMPLX(AVD, BVD)                                           04080829
           IF (R2E(1) -  0.96870E+00) 20230, 40232, 40231               04090829
40231      IF (R2E(1) -  0.96880E+00) 40232, 40232, 20230               04100829
40232      IF (R2E(2) -  0.34998E+00) 20230, 10230, 40230               04110829
40230      IF (R2E(2) -  0.35002E+00) 10230, 10230, 20230               04120829
10230      IVPASS = IVPASS + 1                                          04130829
           WRITE (NUVI, 80002) IVTNUM                                   04140829
           GO TO 0231                                                   04150829
20230      IVFAIL = IVFAIL + 1                                          04160829
           ZVCORR = (0.96875, 0.35)                                     04170829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      04180829
 0231      CONTINUE                                                     04190829
CT024*  TEST 24                         TEST OF INT AND =               04200829
C*****                                          WITH REAL EXPR          04210829
           IVTNUM = 24                                                  04220829
        CVS = 0.0                                                       04230829
        CVD = 0.0D0                                                     04240829
        CVC = (0.0,0.0)                                                 04250829
        LVI = 0                                                         04260829
        AVS = 5.0                                                       04270829
        IVI = 1.0 * 5.0 + 6.0                                           04280829
        KVI = LVI + INT(1.0 * AVS + 6.0)                                04290829
           IF (KVI -    11) 20240, 10240, 20240                         04300829
10240      IVPASS = IVPASS + 1                                          04310829
           WRITE (NUVI, 80002) IVTNUM                                   04320829
           GO TO 0241                                                   04330829
20240      IVFAIL = IVFAIL + 1                                          04340829
           IVCORR =    11                                               04350829
           WRITE (NUVI, 80010) IVTNUM, KVI, IVCORR                      04360829
 0241      CONTINUE                                                     04370829
CT025*  TEST 25                                 WITH DOUBLE PREC EXPR   04380829
           IVTNUM = 25                                                  04390829
        AVD = 3.48D0                                                    04400829
        IVI = 3.48D0 * 47.98D0                                          04410829
        KVI = LVI + INT(AVD * 47.98D0)                                  04420829
           IF (KVI -   166) 20250, 10250, 20250                         04430829
10250      IVPASS = IVPASS + 1                                          04440829
           WRITE (NUVI, 80002) IVTNUM                                   04450829
           GO TO 0251                                                   04460829
20250      IVFAIL = IVFAIL + 1                                          04470829
           IVCORR =   166                                               04480829
           WRITE (NUVI, 80010) IVTNUM, KVI, IVCORR                      04490829
 0251      CONTINUE                                                     04500829
CT026*  TEST 26                                 WITH COMPLEX EXPR       04510829
           IVTNUM = 26                                                  04520829
        AVC = (3.9, 5.0)                                                04530829
        IVI = (3.4, 4.5) + (3.9, 5.0)                                   04540829
        KVI = LVI + INT((3.4, 4.5) + AVC)                               04550829
           IF (KVI -     7) 20260, 10260, 20260                         04560829
10260      IVPASS = IVPASS + 1                                          04570829
           WRITE (NUVI, 80002) IVTNUM                                   04580829
           GO TO 0261                                                   04590829
20260      IVFAIL = IVFAIL + 1                                          04600829
           IVCORR =     7                                               04610829
           WRITE (NUVI, 80010) IVTNUM, KVI, IVCORR                      04620829
 0261      CONTINUE                                                     04630829
CT027*  TEST 27                         TEST OF REAL AND =              04640829
C*****                                          WITH INT EXPR           04650829
           IVTNUM = 27                                                  04660829
        IVI = 20                                                        04670829
        AVS = 20 + 34 / 20                                              04680829
        BVS = CVS + REAL(IVI + 34 / IVI)                                04690829
           IF (BVS -  0.20999E+02) 20270, 10270, 40270                  04700829
40270      IF (BVS -  0.21001E+02) 10270, 10270, 20270                  04710829
10270      IVPASS = IVPASS + 1                                          04720829
           WRITE (NUVI, 80002) IVTNUM                                   04730829
           GO TO 0271                                                   04740829
20270      IVFAIL = IVFAIL + 1                                          04750829
           RVCORR = 21.0                                                04760829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      04770829
 0271      CONTINUE                                                     04780829
CT028*  TEST 28                                 WITH DOUBLE PREC EXPR   04790829
           IVTNUM = 28                                                  04800829
        JVI = 28                                                        04810829
        AVD = 0.9834D0                                                  04820829
        AVS = 3.0748D0 / 0.9834D0                                       04830829
        BVS = CVS + REAL(3.0748D0 / AVD)                                04840829
           IF (BVS -  0.31265E+01) 20280, 10280, 40280                  04850829
40280      IF (BVS -  0.31269E+01) 10280, 10280, 20280                  04860829
10280      IVPASS = IVPASS + 1                                          04870829
           WRITE (NUVI, 80002) IVTNUM                                   04880829
           GO TO 0281                                                   04890829
20280      IVFAIL = IVFAIL + 1                                          04900829
           RVCORR = 3.1267033                                           04910829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      04920829
 0281      CONTINUE                                                     04930829
CT029*  TEST 29                                 WITH COMPLEX            04940829
           IVTNUM = 29                                                  04950829
        JVI = 29                                                        04960829
        AVC = (1.0, 384.9)                                              04970829
        AVS = (3.495, 98.734) * (1.0, 384.9)                            04980829
        BVS = CVS + REAL((3.495, 98.734) * AVC)                         04990829
           IF (BVS +  0.38001E+05) 20290, 10290, 40290                  05000829
40290      IF (BVS +  0.37997E+05) 10290, 10290, 20290                  05010829
10290      IVPASS = IVPASS + 1                                          05020829
           WRITE (NUVI, 80002) IVTNUM                                   05030829
           GO TO 0291                                                   05040829
20290      IVFAIL = IVFAIL + 1                                          05050829
           RVCORR = -37999.222                                          05060829
           WRITE (NUVI, 80012) IVTNUM, BVS, RVCORR                      05070829
 0291      CONTINUE                                                     05080829
CT030*  TEST 30                         TEST OF DBLE AND =              05090829
C*****                                          WITH INTEGER EXPR       05100829
           IVTNUM = 30                                                  05110829
        JVI = 30                                                        05120829
        IVI = 5                                                         05130829
        AVD = 1 * 5 + 6                                                 05140829
        BVD = CVD + DBLE(1 * IVI + 6)                                   05150829
           IF (BVD -  0.10999D+02) 20300, 10300, 40300                  05160829
40300      IF (BVD -  0.11001D+02) 10300, 10300, 20300                  05170829
10300      IVPASS = IVPASS + 1                                          05180829
           WRITE (NUVI, 80002) IVTNUM                                   05190829
           GO TO 0301                                                   05200829
20300      IVFAIL = IVFAIL + 1                                          05210829
           DVCORR = .11000000D+02                                       05220829
           WRITE (NUVI, 80031) IVTNUM, BVD, DVCORR                      05230829
 0301      CONTINUE                                                     05240829
CT031*  TEST 31                                 WITH REAL EXPR          05250829
           IVTNUM = 31                                                  05260829
        JVI = 31                                                        05270829
        AVS = -4.5                                                      05280829
        AVD = 1.3 / (-4.5)                                              05290829
        BVD = CVD + DBLE(1.3 / AVS)                                     05300829
           IF (BVD +  0.28891D+00) 20310, 10310, 40310                  05310829
40310      IF (BVD +  0.28887D+00) 10310, 10310, 20310                  05320829
10310      IVPASS = IVPASS + 1                                          05330829
           WRITE (NUVI, 80002) IVTNUM                                   05340829
           GO TO 0311                                                   05350829
20310      IVFAIL = IVFAIL + 1                                          05360829
           DVCORR = -0.288888888888888889D+00                           05370829
           WRITE (NUVI, 80031) IVTNUM, BVD, DVCORR                      05380829
 0311      CONTINUE                                                     05390829
CT032*  TEST 32                                 WITH COMPLEX EXPR       05400829
           IVTNUM = 32                                                  05410829
        JVI = 32                                                        05420829
        AVC = (3.9, 5.0)                                                05430829
        AVD = (3.4, 4.5) + (3.9, 5.0)                                   05440829
        BVD = CVD + DBLE((3.4, 4.5) + AVC)                              05450829
           IF (BVD -  0.72996D+01) 20320, 10320, 40320                  05460829
40320      IF (BVD -  0.73004D+01) 10320, 10320, 20320                  05470829
10320      IVPASS = IVPASS + 1                                          05480829
           WRITE (NUVI, 80002) IVTNUM                                   05490829
           GO TO 0321                                                   05500829
20320      IVFAIL = IVFAIL + 1                                          05510829
           DVCORR = .73000000D+01                                       05520829
           WRITE (NUVI, 80031) IVTNUM, BVD, DVCORR                      05530829
 0321      CONTINUE                                                     05540829
CT033*  TEST 33                         TEST OF CMPLX AND =             05550829
C*****                                          WITH INTEGER EXPR       05560829
           IVTNUM = 33                                                  05570829
        JVI = 33                                                        05580829
        IVI = 673                                                       05590829
        AVC = 394 - 673                                                 05600829
        BVC = CVC + CMPLX(394 - IVI)                                    05610829
           IF (R2E(1) +  0.27902E+03) 20330, 40332, 40331               05620829
40331      IF (R2E(1) +  0.27898E+03) 40332, 40332, 20330               05630829
40332      IF (R2E(2) +  0.50000E-04) 20330, 10330, 40330               05640829
40330      IF (R2E(2) -  0.50000E-04) 10330, 10330, 20330               05650829
10330      IVPASS = IVPASS + 1                                          05660829
           WRITE (NUVI, 80002) IVTNUM                                   05670829
           GO TO 0331                                                   05680829
20330      IVFAIL = IVFAIL + 1                                          05690829
           ZVCORR = (-279.00000, .00000000)                             05700829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      05710829
 0331      CONTINUE                                                     05720829
CT034*  TEST 34                                 WITH REAL EXPR          05730829
           IVTNUM = 34                                                  05740829
        JVI = 34                                                        05750829
        AVS = 3.48                                                      05760829
        AVC = 3.48 * 47.98                                              05770829
        BVC = CVC + CMPLX(AVS * 47.98)                                  05780829
           IF (R2E(1) -  0.16696E+03) 20340, 40342, 40341               05790829
40341      IF (R2E(1) -  0.16698E+03) 40342, 40342, 20340               05800829
40342      IF (R2E(2) +  0.50000E-04) 20340, 10340, 40340               05810829
40340      IF (R2E(2) -  0.50000E-04) 10340, 10340, 20340               05820829
10340      IVPASS = IVPASS + 1                                          05830829
           WRITE (NUVI, 80002) IVTNUM                                   05840829
           GO TO 0341                                                   05850829
20340      IVFAIL = IVFAIL + 1                                          05860829
           ZVCORR = (166.97040, .00000000)                              05870829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      05880829
 0341      CONTINUE                                                     05890829
CT035*  TEST 35                                                         05900829
           IVTNUM = 35                                                  05910829
        JVI = 35                                                        05920829
        AVD = 0.94D1                                                    05930829
        AVC = 3.0283D3 / 0.94D1                                         05940829
        BVC = CVC + CMPLX(3.0283D3 / AVD)                               05950829
           IF (R2E(1) -  0.32214E+03) 20350, 40352, 40351               05960829
40351      IF (R2E(1) -  0.32218E+03) 40352, 40352, 20350               05970829
40352      IF (R2E(2) +  0.50000E-04) 20350, 10350, 40350               05980829
40350      IF (R2E(2) -  0.50000E-04) 10350, 10350, 20350               05990829
10350      IVPASS = IVPASS + 1                                          06000829
           WRITE (NUVI, 80002) IVTNUM                                   06010829
           GO TO 0351                                                   06020829
20350      IVFAIL = IVFAIL + 1                                          06030829
           ZVCORR = (322.15957, .000000000)                             06040829
           WRITE (NUVI, 80045) IVTNUM, BVC, ZVCORR                      06050829
 0351      CONTINUE                                                     06060829
C*****                                                                  06070829
CBB** ********************** BBCSUM0  **********************************06080829
C**** WRITE OUT TEST SUMMARY                                            06090829
C****                                                                   06100829
      IVTOTN = IVPASS + IVFAIL + IVDELE + IVINSP                        06110829
      WRITE (I02, 90004)                                                06120829
      WRITE (I02, 90014)                                                06130829
      WRITE (I02, 90004)                                                06140829
      WRITE (I02, 90020) IVPASS                                         06150829
      WRITE (I02, 90022) IVFAIL                                         06160829
      WRITE (I02, 90024) IVDELE                                         06170829
      WRITE (I02, 90026) IVINSP                                         06180829
      WRITE (I02, 90028) IVTOTN, IVTOTL                                 06190829
CBE** ********************** BBCSUM0  **********************************06200829
CBB** ********************** BBCFOOT0 **********************************06210829
C**** WRITE OUT REPORT FOOTINGS                                         06220829
C****                                                                   06230829
      WRITE (I02,90016) ZPROG, ZPROG                                    06240829
      WRITE (I02,90018) ZPROJ, ZNAME, ZTAPE, ZTAPED                     06250829
      WRITE (I02,90019)                                                 06260829
CBE** ********************** BBCFOOT0 **********************************06270829
CBB** ********************** BBCFMT0A **********************************06280829
C**** FORMATS FOR TEST DETAIL LINES                                     06290829
C****                                                                   06300829
80000 FORMAT (" ",2X,I3,4X,"DELETED",32X,A31)                           06310829
80002 FORMAT (" ",2X,I3,4X," PASS  ",32X,A31)                           06320829
80004 FORMAT (" ",2X,I3,4X,"INSPECT",32X,A31)                           06330829
80008 FORMAT (" ",2X,I3,4X," FAIL  ",32X,A31)                           06340829
80010 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",15X,"COMPUTED= " ,           06350829
     1I6,/," ",15X,"CORRECT=  " ,I6)                                    06360829
80012 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           06370829
     1E12.5,/," ",16X,"CORRECT=  " ,E12.5)                              06380829
80018 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           06390829
     1A21,/," ",16X,"CORRECT=  " ,A21)                                  06400829
80020 FORMAT (" ",16X,"COMPUTED= " ,A21,1X,A31)                         06410829
80022 FORMAT (" ",16X,"CORRECT=  " ,A21,1X,A31)                         06420829
80024 FORMAT (" ",16X,"COMPUTED= " ,I6,16X,A31)                         06430829
80026 FORMAT (" ",16X,"CORRECT=  " ,I6,16X,A31)                         06440829
80028 FORMAT (" ",16X,"COMPUTED= " ,E12.5,10X,A31)                      06450829
80030 FORMAT (" ",16X,"CORRECT=  " ,E12.5,10X,A31)                      06460829
80050 FORMAT (" ",48X,A31)                                              06470829
CBE** ********************** BBCFMT0A **********************************06480829
CBB** ********************** BBCFMAT1 **********************************06490829
C**** FORMATS FOR TEST DETAIL LINES - FULL LANGUAGE                     06500829
C****                                                                   06510829
80031 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           06520829
     1D17.10,/," ",16X,"CORRECT=  " ,D17.10)                            06530829
80033 FORMAT (" ",16X,"COMPUTED= " ,D17.10,10X,A31)                     06540829
80035 FORMAT (" ",16X,"CORRECT=  " ,D17.10,10X,A31)                     06550829
80037 FORMAT (" ",16X,"COMPUTED= " ,"(",E12.5,", ",E12.5,")",6X,A31)    06560829
80039 FORMAT (" ",16X,"CORRECT=  " ,"(",E12.5,", ",E12.5,")",6X,A31)    06570829
80041 FORMAT (" ",16X,"COMPUTED= " ,"(",F12.5,", ",F12.5,")",6X,A31)    06580829
80043 FORMAT (" ",16X,"CORRECT=  " ,"(",F12.5,", ",F12.5,")",6X,A31)    06590829
80045 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           06600829
     1"(",F12.5,", ",F12.5,")"/," ",16X,"CORRECT=  " ,                  06610829
     2"(",F12.5,", ",F12.5,")")                                         06620829
CBE** ********************** BBCFMAT1 **********************************06630829
CBB** ********************** BBCFMT0B **********************************06640829
C**** FORMAT STATEMENTS FOR PAGE HEADERS                                06650829
C****                                                                   06660829
90002 FORMAT ("1")                                                      06670829
90004 FORMAT (" ")                                                      06680829
90006 FORMAT (" ",20X,"NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY" )06690829
90007 FORMAT (" ",19X,"FORTRAN COMPILER VALIDATION SYSTEM" )            06700829
90008 FORMAT (" ",21X,A13,A17)                                          06710829
90009 FORMAT (" ",/," *",A5,"BEGIN*",12X,"TEST RESULTS - " ,A5,/)       06720829
90010 FORMAT (" ",8X,"TEST DATE*TIME= " ,A17,"  -  COMPILER= " ,A20)    06730829
90013 FORMAT (" "," TEST   ","PASS/FAIL " ,6X,"DISPLAYED RESULTS" ,     06740829
     1       7X,"REMARKS",24X)                                          06750829
90014 FORMAT (" ","----------------------------------------------" ,    06760829
     1        "---------------------------------" )                     06770829
90015 FORMAT (" ",48X,"THIS PROGRAM HAS " ,I3," TESTS",/)               06780829
C****                                                                   06790829
C**** FORMAT STATEMENTS FOR REPORT FOOTINGS                             06800829
C****                                                                   06810829
90016 FORMAT (" ",/," *",A5,"END*",14X,"END OF TEST - " ,A5,/)          06820829
90018 FORMAT (" ",A13,13X,A20,"   *   ",A10,"/",                        06830829
     1        A13)                                                      06840829
90019 FORMAT (" ","FOR OFFICIAL USE ONLY     " ,35X,"COPYRIGHT  1982" ) 06850829
C****                                                                   06860829
C**** FORMAT STATEMENTS FOR RUN SUMMARY                                 06870829
C****                                                                   06880829
90020 FORMAT (" ",21X,I5," TESTS PASSED" )                              06890829
90022 FORMAT (" ",21X,I5," TESTS FAILED" )                              06900829
90024 FORMAT (" ",21X,I5," TESTS DELETED" )                             06910829
90026 FORMAT (" ",21X,I5," TESTS REQUIRE INSPECTION" )                  06920829
90028 FORMAT (" ",21X,I5," OF ",I3," TESTS EXECUTED" )                  06930829
CBE** ********************** BBCFMT0B **********************************06940829
C*****                                                                  06950829
C*****    END OF TEST SEGMENT 206                                       06960829
      STOP                                                              06970829
      END                                                               06980829

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:
C   IMSL ROUTINE NAME   - ZSPWE                                         ZSPV0010
C                                                                       ZSPV0020
C-----------------------------------------------------------------------ZSPV0030
C                                                                       ZSPV0040
C   COMPUTER            - VAX/SINGLE                                    ZSPV0050
C                                                                       ZSPV0060
C   LATEST REVISION     - JUNE 1, 1982                                  ZSPV0070
C                                                                       ZSPV0080
C   PURPOSE             - NUCLEUS CALLED ONLY BY IMSL SUBROUTINE ZSPOW  ZSPV0090
C                                                                       ZSPV0100
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32                         ZSPV0110
C                       - SINGLE/H36,H48,H60                            ZSPV0120
C                                                                       ZSPV0130
C   REQD. IMSL ROUTINES - NONE REQUIRED                                 ZSPV0140
C                                                                       ZSPV0150
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND           ZSPV0160
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL      ZSPV0170
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP  ZSPV0180
C                                                                       ZSPV0190
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.       ZSPV0200
C                                                                       ZSPV0210
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN ZSPV0220
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,    ZSPV0230
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.        ZSPV0240
C                                                                       ZSPV0250
C-----------------------------------------------------------------------ZSPV0260
C                                                                       ZSPV0270
      SUBROUTINE ZSPWE (M,N,S,LS,U,V,W,SING)                            ZSPV0280
C                                  SPECIFICATIONS FOR ARGUMENTS         ZSPV0290
      INTEGER            M,N,LS                                         ZSPV0300
      REAL               S(LS),U(M),V(N),W(M)                           ZSPV0310
      LOGICAL            SING                                           ZSPV0320
C                                  SPECIFICATIONS FOR LOCAL VARIABLES   ZSPV0330
      INTEGER            I,JJ,J,L,NM1,NMJ                               ZSPV0340
      REAL               TEMP1,TEMP2,GIANT,ONE,P25,P5,TEMP3,SPMPAR,     ZSPV0350
     *                   TEMP4,TAU,TEMP,ZERO                            ZSPV0360
      DATA               GIANT /1.7E+38/                                ZSPV0370
      DATA               ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/    ZSPV0380
C                                  INITIALIZE THE DIAGONAL ELEMENT      ZSPV0390
C                                  POINTER.                             ZSPV0400
C                                  FIRST EXECUTABLE STATEMENT           ZSPV0410
      JJ = (N*(2*M-N+1))/2-(M-N)                                        ZSPV0420
C                                  MOVE THE NONTRIVIAL PART OF THE LAST ZSPV0430
C                                  COLUMN OF S INTO W.                  ZSPV0440
      L = JJ                                                            ZSPV0450
      DO 5 I=N,M                                                        ZSPV0460
         W(I) = S(L)                                                    ZSPV0470
         L = L+1                                                        ZSPV0480
    5 CONTINUE                                                          ZSPV0490
C                                  ROTATE THE VECTOR V INTO A MULTIPLE  ZSPV0500
C                                  OF THE N-TH UNIT VECTOR IN SUCH A WAYZSPV0510
C                                  THAT A SPIKE IS INTRODUCED INTO W.   ZSPV0520
      NM1 = N-1                                                         ZSPV0530
      IF (NM1.LT.1) GO TO 35                                            ZSPV0540
      DO 30 NMJ=1,NM1                                                   ZSPV0550
         J = N-NMJ                                                      ZSPV0560
         JJ = JJ-(M-J+1)                                                ZSPV0570
         W(J) = ZERO                                                    ZSPV0580
         IF (V(J).EQ.ZERO) GO TO 25                                     ZSPV0590
C                                  DETERMINE A GIVENS ROTATION WHICH    ZSPV0600
C                                  ELIMINATES THE J-TH ELEMENT OF V.    ZSPV0610
         IF (ABS(V(N)).GE.ABS(V(J))) GO TO 10                           ZSPV0620
         TEMP2 = V(N)/V(J)                                              ZSPV0630
         TEMP3 = P5/SQRT(P25+P25*TEMP2**2)                              ZSPV0640
         TEMP1 = TEMP3*TEMP2                                            ZSPV0650
         TAU = ONE                                                      ZSPV0660
         IF (ABS(TEMP1)*GIANT.GT.ONE) TAU = ONE/TEMP1                   ZSPV0670
         GO TO 15                                                       ZSPV0680
   10    CONTINUE                                                       ZSPV0690
         TEMP4 = V(J)/V(N)                                              ZSPV0700
         TEMP1 = P5/SQRT(P25+P25*TEMP4**2)                              ZSPV0710
         TEMP3 = TEMP1*TEMP4                                            ZSPV0720
         TAU = TEMP3                                                    ZSPV0730
   15    CONTINUE                                                       ZSPV0740
C                                  APPLY THE TRANSFORMATION TO V AND    ZSPV0750
C                                  STORE THE INFORMATION NECESSARY TO   ZSPV0760
C                                  RECOVER THE GIVENS ROTATION.         ZSPV0770
         V(N) = TEMP3*V(J)+TEMP1*V(N)                                   ZSPV0780
         V(J) = TAU                                                     ZSPV0790
C                                  APPLY THE TRANSFORMATION TO S AND    ZSPV0800
C                                  EXTEND THE SPIKE IN W.               ZSPV0810
         L = JJ                                                         ZSPV0820
         DO 20 I=J,M                                                    ZSPV0830
            TEMP = TEMP1*S(L)-TEMP3*W(I)                                ZSPV0840
            W(I) = TEMP3*S(L)+TEMP1*W(I)                                ZSPV0850
            S(L) = TEMP                                                 ZSPV0860
            L = L+1                                                     ZSPV0870
   20    CONTINUE                                                       ZSPV0880
   25    CONTINUE                                                       ZSPV0890
   30 CONTINUE                                                          ZSPV0900
   35 CONTINUE                                                          ZSPV0910
C                                  ADD THE SPIKE FROM THE RANK 1 UPDATE ZSPV0920
C                                  TO W.                                ZSPV0930
      DO 40 I=1,M                                                       ZSPV0940
         W(I) = W(I)+V(N)*U(I)                                          ZSPV0950
   40 CONTINUE                                                          ZSPV0960
C                                  ELIMINATE THE SPIKE.                 ZSPV0970
      SING = .FALSE.                                                    ZSPV0980
      IF (NM1.LT.1) GO TO 70                                            ZSPV0990
      DO 65 J=1,NM1                                                     ZSPV1000
         IF (W(J).EQ.ZERO) GO TO 60                                     ZSPV1010
C                                  DETERMINE A GIVENS ROTATION WHICH    ZSPV1020
C                                  ELIMINATES THE J-TH ELEMENT OF THE   ZSPV1030
C                                  SPIKE.                               ZSPV1040
         IF (ABS(S(JJ)).GE.ABS(W(J))) GO TO 45                          ZSPV1050
         TEMP2 = S(JJ)/W(J)                                             ZSPV1060
         TEMP3 = P5/SQRT(P25+P25*TEMP2**2)                              ZSPV1070
         TEMP1 = TEMP3*TEMP2                                            ZSPV1080
         TAU = ONE                                                      ZSPV1090
         IF (ABS(TEMP1)*GIANT.GT.ONE) TAU = ONE/TEMP1                   ZSPV1100
         GO TO 50                                                       ZSPV1110
   45    CONTINUE                                                       ZSPV1120
         TEMP4 = W(J)/S(JJ)                                             ZSPV1130
         TEMP1 = P5/SQRT(P25+P25*TEMP4**2)                              ZSPV1140
         TEMP3 = TEMP1*TEMP4                                            ZSPV1150
         TAU = TEMP3                                                    ZSPV1160
   50    CONTINUE                                                       ZSPV1170
C                                  APPLY THE TRANSFORMATION TO S AND    ZSPV1180
C                                  REDUCE THE SPIKE IN W.               ZSPV1190
         L = JJ                                                         ZSPV1200
         DO 55 I=J,M                                                    ZSPV1210
            TEMP = TEMP1*S(L)+TEMP3*W(I)                                ZSPV1220
            W(I) = -TEMP3*S(L)+TEMP1*W(I)                               ZSPV1230
            S(L) = TEMP                                                 ZSPV1240
            L = L+1                                                     ZSPV1250
   55    CONTINUE                                                       ZSPV1260
C                                  STORE THE INFORMATION NECESSARY TO   ZSPV1270
C                                  RECOVER THE GIVENS ROTATION.         ZSPV1280
         W(J) = TAU                                                     ZSPV1290
   60    CONTINUE                                                       ZSPV1300
C                                  TEST FOR ZERO DIAGONAL ELEMENTS IN   ZSPV1310
C                                  THE OUTPUT S.                        ZSPV1320
         IF (S(JJ).EQ.ZERO) SING = .TRUE.                               ZSPV1330
         JJ = JJ+(M-J+1)                                                ZSPV1340
   65 CONTINUE                                                          ZSPV1350
   70 CONTINUE                                                          ZSPV1360
C                                  MOVE W BACK INTO THE LAST COLUMN OF  ZSPV1370
C                                  THE OUTPUT S.                        ZSPV1380
      L = JJ                                                            ZSPV1390
      DO 75 I=N,M                                                       ZSPV1400
         S(L) = W(I)                                                    ZSPV1410
         L = L+1                                                        ZSPV1420
   75 CONTINUE                                                          ZSPV1430
      IF (S(JJ).EQ.ZERO) SING = .TRUE.                                  ZSPV1440
      RETURN                                                            ZSPV1450
      END                                                               ZSPV1460

ext: f

max_stars_repo_name: imohame/LabCode

max_issues_repo_name: imohame/LabCode

max_forks_repo_name: imohame/LabCode


text:
!!# FUNCTION MODULE: <FUN_Error>
MODULE FUN_Error

!!## PURPOSE
!! Provide a error function, taking an argument and
!! returning the ``error number''---a number that indicates
!! a variable's value is currently in some unknown error
!! state.

!!## USAGE
!
!  x = Error(x)
!

!!## DETAILS
!! This is useful in low-level procedures where passing
!! information about the successful completion of the routine
!! via an information flag is not desired.  Instead, if
!! a error occurs in the low-level routine, you just set
!! < x=Error(x) >.  At the appropriate time, a check
!! should be made on the value of <x> to check for errors
!! using either < x==Error(x) > or < IsError(x) >.

!!## OWNER
! W.A. Wieselquist | william.wieselquist@gmail.com

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes                        !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL STANDARDS
USE ISO_varying_string                        !!((03-A-ISO_varying_string.f90))

!!## EXTERNAL PROCEDURES
USE FUN_Huge                                  !!((03-A-FUN_Huge.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### PROCEDURE OVERLOADING
INTERFACE Error
 MODULE PROCEDURE Error_E0Csp
 MODULE PROCEDURE Error_E0Cdp
 MODULE PROCEDURE Error_E0Rsp
 MODULE PROCEDURE Error_E0Rdp
 MODULE PROCEDURE Error_E0I1
 MODULE PROCEDURE Error_E0I2
 MODULE PROCEDURE Error_E0I4
 MODULE PROCEDURE Error_E0I8
 MODULE PROCEDURE Error_E0S
 MODULE PROCEDURE Error_E0VS
END INTERFACE

!!### EXTERNAL PARAMETERS
INTEGER(KIND_I)             ,PARAMETER :: Error_I   = -HUGE(1_KIND_I)
INTEGER(KIND_I1)            ,PARAMETER :: Error_I1  = -HUGE(1_KIND_I1)
INTEGER(KIND_I2)            ,PARAMETER :: Error_I2  = -HUGE(1_KIND_I2)
INTEGER(KIND_I4)            ,PARAMETER :: Error_I4  = -HUGE(1_KIND_I4)
INTEGER(KIND_I8)            ,PARAMETER :: Error_I8  = -HUGE(1_KIND_I8)
REAL(KIND_R)                ,PARAMETER :: Error_R   = -HUGE(1._KIND_R)
REAL(KIND_Rsp)              ,PARAMETER :: Error_Rsp = -HUGE(1._KIND_Rsp)
REAL(KIND_Rdp)              ,PARAMETER :: Error_Rdp = -HUGE(1._KIND_Rdp)
COMPLEX(KIND_C)             ,PARAMETER :: Error_C   = -HUGE_C
COMPLEX(KIND_Csp)           ,PARAMETER :: Error_Csp = -HUGE_Csp
COMPLEX(KIND_Cdp)           ,PARAMETER :: Error_Cdp = -HUGE_Cdp
CHARACTER(LEN=*,KIND=KIND_S),PARAMETER :: Error_S   = " "

!!### PUBLIC ACCESS LIST
!! @ function
PUBLIC :: Error
!! @ constants
PUBLIC :: Error_I,Error_I1,Error_I2,Error_I4,Error_I8,&
          Error_R,Error_Rsp,Error_Rdp,&
          Error_C,Error_Csp,Error_Cdp,Error_S

!!## MODULE PROCEDURES
CONTAINS

PURE ELEMENTAL FUNCTION Error_E0Rsp(B) RESULT(A)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_Error_E0R.f90.hdr"
!
A = Error_Rsp
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0Rdp(B) RESULT(A)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_Error_E0R.f90.hdr"
!
A = Error_Rdp
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0Csp(B) RESULT(A)
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_Error_E0C.f90.hdr"
!
A = Error_Csp
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0Cdp(B) RESULT(A)
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_Error_E0C.f90.hdr"
!
A = Error_Cdp
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0I1(B) RESULT(A)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_Error_E0I.f90.hdr"
!
A = Error_I1
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0I2(B) RESULT(A)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_Error_E0I.f90.hdr"
!
A = Error_I2
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0I4(B) RESULT(A)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_Error_E0I.f90.hdr"
!
A = Error_I4
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0I8(B) RESULT(A)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_Error_E0I.f90.hdr"
!
A = Error_I8
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0S(B) RESULT(A)
INCLUDE "04-A-FUN_Error_E0S.f90.hdr"
!
A = Error_S
!
END FUNCTION

PURE ELEMENTAL FUNCTION Error_E0VS(B) RESULT(A)
INCLUDE "04-A-FUN_Error_E0VS.f90.hdr"
!
A = Error_S
!
END FUNCTION

END MODULE

max_stars_repo_name: wawiesel/tapack

max_issues_repo_name: wawiesel/tapack

max_forks_repo_name: wawiesel/tapack


!
! wrappers for markovst_dgesv_mod.f90
!

subroutine f90_markovst_dgesv_dense(n, Q, ldq, x, incx, info)
  use markovst_dgesv
  integer, intent(in) :: n, ldq, incx
  double precision, intent(in) :: Q(1:ldq,1:n)
  double precision, intent(out) :: x(1:incx,1:n)
  integer, intent(out) :: info

  call markovst_dgesv_dense(n, Q, ldq, x, incx, info)
end subroutine f90_markovst_dgesv_dense

subroutine f90_markovst_dgesv_csr(n, spQ, rowptr, colind, nnz, x, incx, info)
  use markovst_dgesv
  integer, intent(in) :: n, nnz, incx
  integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
  double precision, intent(in) :: spQ(1:nnz)
  double precision, intent(out) :: x(1:incx,1:n)
  integer, intent(out) :: info

  call markovst_dgesv_csr(n, spQ, rowptr, colind, nnz, x, incx, info)
end subroutine f90_markovst_dgesv_csr

subroutine f90_markovst_dgesv_csc(n, spQ, colptr, rowind, nnz, x, incx, info)
  use markovst_dgesv
  integer, intent(in) :: n, nnz, incx
  integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
  double precision, intent(in) :: spQ(1:nnz)
  double precision, intent(out) :: x(1:incx,1:n)
  integer, intent(out) :: info

  call markovst_dgesv_csc(n, spQ, colptr, rowind, nnz, x, incx, info)
end subroutine f90_markovst_dgesv_csc

subroutine f90_markovst_dgesv_coo(n, spQ, rowind, colind, nnz, x, incx, info)
  use markovst_dgesv
  integer, intent(in) :: n, nnz, incx
  integer, intent(in) :: rowind(1:nnz), colind(1:nnz)
  double precision, intent(in) :: spQ(1:nnz)
  double precision, intent(out) :: x(1:incx,1:n)
  integer, intent(out) :: info

  call markovst_dgesv_coo(n, spQ, rowind, colind, nnz, x, incx, info)
end subroutine f90_markovst_dgesv_coo


! { dg-do compile }
! { dg-additional-options "-fmax-errors=100" }

program test
  implicit none
  integer :: i, j, static, num, length

  !$acc kernels
    !$acc loop gang(static:static)
    DO i = 1,10
    ENDDO
    !$acc loop gang(static:*)
    DO i = 1,10
    ENDDO
    !$acc loop gang(static:1)
    DO i = 1,10
    ENDDO
    !$acc loop gang(,static:1) ! { dg-error "Invalid character" }
    DO i = 1,10
    ENDDO
    !$acc loop gang(static:1,) ! { dg-error "Invalid character" }
    DO i = 1,10
    ENDDO
    !$acc loop gang(static:*, num:5)
    DO i = 1,10
    ENDDO
    !$acc loop gang(static:1, 5)
    DO i = 1,10
    ENDDO
    !$acc loop gang(num:num, static:1)
    DO i = 1,10
    ENDDO
    !$acc loop gang(static:*, num:5, static:5) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop gang(1, num:2, static:3) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop gang(num:num static:1) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop gang(num)
    DO i = 1,10
    ENDDO
    !$acc loop gang(num:num+1, static:1+num)
    DO i = 1,10
    ENDDO
    !$acc loop gang(length:num) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO

    !$acc loop worker
    DO i = 1,10
    ENDDO
    !$acc loop worker (5)
    DO i = 1,10
    ENDDO
    !$acc loop worker (num)
    DO i = 1,10
    ENDDO
    !$acc loop worker (static:num) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop worker (num:,) ! { dg-error "Invalid character" }
    DO i = 1,10
    ENDDO
    !$acc loop worker (num:num:num) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop worker (num:num*num)
    DO i = 1,10
    ENDDO
    !$acc loop worker (length:num*num) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop worker (num:*) ! { dg-error "Invalid character" }
    DO i = 1,10
    ENDDO
    !$acc loop worker (num:5)
    DO i = 1,10
    ENDDO

    !$acc loop vector
    DO i = 1,10
    ENDDO
    !$acc loop vector (32)
    DO i = 1,10
    ENDDO
    !$acc loop vector (length)
    DO i = 1,10
    ENDDO
    !$acc loop vrctor (static:num) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop vector (length:,) ! { dg-error "Invalid character" }
    DO i = 1,10
    ENDDO
    !$acc loop vector (length:num:num) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop vector (length:static*num)
    DO i = 1,10
    ENDDO
    !$acc loop vector (length:length)
    DO i = 1,10
    ENDDO
    !$acc loop vector (length:32)
    DO i = 1,10
    ENDDO
    !$acc loop vector (num:num*num) ! { dg-error "Unclassifiable OpenACC directive" }
    DO i = 1,10
    ENDDO
    !$acc loop vector (length:*) ! { dg-error "Invalid character" }
    DO i = 1,10
    ENDDO

    !$acc loop auto
    DO i = 1,10
    ENDDO
  !$acc end kernels
end


MODULE shared_data
!
!  Purpose:
!    To declare data to share between two routines.

IMPLICIT NONE
SAVE

INTEGER, PARAMETER :: NUM_VALS = 5       ! Max number of values in array
REAL, DIMENSION(NUM_VALS) :: values      ! Data values

END MODULE shared_data


MODULE SharedTypes
!
!----------------------------------------------------------------------------------------------------

   USE                              NWTC_Library

   IMPLICIT NONE

   !-------------------------------------------------------------------------------------------------
   ! Public types and subroutines
   !-------------------------------------------------------------------------------------------------
   TYPE, PUBLIC :: Marker
      REAL(ReKi)                 :: Position(3)
      REAL(ReKi)                 :: Orientation(3,3)     ! Direction Cosine Matrix (DCM)
      REAL(ReKi)                 :: TranslationVel(3)
      REAL(ReKi)                 :: RotationVel(3)
   END TYPE Marker

   TYPE, PUBLIC :: Load
      REAL(ReKi)                 :: Force(3)
      REAL(ReKi)                 :: Moment(3)
   END TYPE Load

   TYPE, PUBLIC :: AllAeroMarkers
      TYPE(Marker), ALLOCATABLE  :: Blade(:,:)
      TYPE(Marker), ALLOCATABLE  :: Hub(:)
      TYPE(Marker), ALLOCATABLE  :: RotorFurl(:)
      TYPE(Marker), ALLOCATABLE  :: Nacelle(:)
      TYPE(Marker), ALLOCATABLE  :: Tower(:)
      TYPE(Marker), ALLOCATABLE  :: Tail(:)
   END TYPE AllAeroMarkers

   TYPE, PUBLIC :: AllAeroLoads
      TYPE(Load),  ALLOCATABLE   :: Blade(:,:)
      TYPE(Load),  ALLOCATABLE   :: Hub(:)
      TYPE(Load),  ALLOCATABLE   :: RotorFurl(:)
      TYPE(Load),  ALLOCATABLE   :: Nacelle(:)
      TYPE(Load),  ALLOCATABLE   :: Tower(:)
      TYPE(Load),  ALLOCATABLE   :: Tail(:)
   END TYPE AllAeroLoads

!   TYPE, PUBLIC :: ProgDesc !do we want to add date as well?
!      CHARACTER(20)              :: Name
!      CHARACTER(99)              :: Ver
!   END TYPE ProgDesc

   TYPE, PUBLIC :: AeroConfig
      TYPE(Marker), ALLOCATABLE  :: Blade(:)
      REAL(ReKi)                 :: BladeLength
      TYPE(Marker)               :: Hub
      TYPE(Marker)               :: RotorFurl
      TYPE(Marker)               :: Nacelle
      TYPE(Marker)               :: TailFin
      TYPE(Marker)               :: Tower
      TYPE(Marker)               :: Substructure
      TYPE(Marker)               :: Foundation
   END TYPE AeroConfig

!====================================================================================================
!CONTAINS
!====================================================================================================
!SUBROUTINE AllocateLoads(LoadVar,NB,NBEle,NHub,NNacelle,NTwr,NTail,ErrorStatus)
!! Allocation subroutine for type AllAeroLoads
!!----------------------------------------------------------------------------------------------------
!
!      ! Passed variables
!
!   TYPE(AllAeroLoads), INTENT(INOUT)   :: LoadVar
!   INTEGER,            INTENT(IN)      :: NB                      ! Number of blades
!   INTEGER,            INTENT(IN)      :: NBEle                   ! Number of elements per blade
!   INTEGER,            INTENT(IN)      :: NHub                    ! Number of elements on the hub
!   INTEGER,            INTENT(IN)      :: NNacelle                ! Number of elements on the nacelle
!   INTEGER,            INTENT(IN)      :: NTwr                    ! Number of elements on the tower
!   INTEGER,            INTENT(IN)      :: NTail                   ! Number of elements on the tail
!   INTEGER,            INTENT(OUT)     :: ErrorStatus             ! Determines if an error was encountered
!
!
!      ! Allocate the states
!
!
!   IF (.NOT. ALLOCATED(LoadVar%Blade) .AND. NB*NBEle > 0 ) THEN
!      ALLOCATE( LoadVar%Blade(NB,NBEle), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   IF (.NOT. ALLOCATED(LoadVar%Hub) .AND. NHub > 0 ) THEN
!      ALLOCATE( LoadVar%Hub(NHub), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   IF (.NOT. ALLOCATED(LoadVar%Nacelle) .AND. NNacelle > 0 ) THEN
!      ALLOCATE( LoadVar%Nacelle(NNacelle), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   IF (.NOT. ALLOCATED(LoadVar%Tower) .AND. NTwr > 0 ) THEN
!      ALLOCATE( LoadVar%Tower(NTwr), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   IF (.NOT. ALLOCATED(LoadVar%Tail) .AND. NTail > 0 ) THEN
!      ALLOCATE( LoadVar%Tail(NTail), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   ErrorStatus = 0
!
!
!END SUBROUTINE AllocateLoads
!!====================================================================================================
!SUBROUTINE AllocateStates(StateVar,NB,NBEle,NHub,NNacelle,NTwr,NTail,ErrorStatus)
!! Allocation subroutine for type AllAeroStates
!!----------------------------------------------------------------------------------------------------
!
!      ! Passed variables
!
!   TYPE(AllAeroStates), INTENT(INOUT)  :: StateVar
!   INTEGER,             INTENT(IN)     :: NB                      ! Number of blades
!   INTEGER,             INTENT(IN)     :: NBEle                   ! Number of elements per blade
!   INTEGER,             INTENT(IN)     :: NHub                    ! Number of elements on the hub
!   INTEGER,             INTENT(IN)     :: NNacelle                ! Number of elements on the nacelle
!   INTEGER,             INTENT(IN)     :: NTwr                    ! Number of elements on the tower
!   INTEGER,             INTENT(IN)     :: NTail                   ! Number of elements on the tail
!   INTEGER,             INTENT(OUT)    :: ErrorStatus             ! Determines if an error was encountered
!
!
!      ! Allocate the states
!
!   IF (.NOT. ALLOCATED(StateVar%Blade) .AND. NB*NBEle > 0 ) THEN
!      ALLOCATE( StateVar%Blade(NB,NBEle), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   IF (.NOT. ALLOCATED(StateVar%Hub) .AND. NHub > 0 ) THEN
!      ALLOCATE( StateVar%Hub(NHub), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   IF (.NOT. ALLOCATED(StateVar%Nacelle) .AND. NNacelle > 0 ) THEN
!      ALLOCATE( StateVar%Nacelle(NNacelle), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   IF (.NOT. ALLOCATED(StateVar%Tower) .AND. NTwr > 0 ) THEN
!      ALLOCATE( StateVar%Tower(NTwr), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   IF (.NOT. ALLOCATED(StateVar%Tail) .AND. NTail > 0 ) THEN
!      ALLOCATE( StateVar%Tail(NTail), STAT=ErrorStatus )
!      IF (ErrorStatus /=0) RETURN
!   ENDIF
!
!   ErrorStatus = 0
!
!
!END SUBROUTINE AllocateStates
!====================================================================================================

END MODULE SharedTypes


text:
!***********************************************************************
!                                                                      *
      SUBROUTINE SETMIX(NAME, IDBLK)
!                                                                      *
!   Opens the  .mix  file on stream 25; writes a header to this file;  *
!   calls LODMIX to interactively determine the eigenpairs required.   *
!                                                                      *
!   Call(s) to: [LIB92]: OPENFL.                                       *
!               [RCI92]: LODMIX.                                       *
!                                                                      *
!   Written by Farid A. Parpia            Last revision: 18 Dec 1992   *
!   Modified by Xinghong He               Last revision: 23 Jun 1998   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE openfl_I
      USE lodmix_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      CHARACTER(LEN=*) , INTENT(IN) :: NAME
      CHARACTER(LEN=8), DIMENSION(*) :: IDBLK
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED'
      CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN'
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K, IERR
!-----------------------------------------------

      K = INDEX(NAME,' ')
      CALL OPENFL (25, NAME(1:K-1)//'.cm', FORM, STATUS, IERR)
      IF (IERR /= 0) STOP 'setmix: Error when opening .cm file'

      WRITE (25) 'G92MIX'

      CALL LODMIX (IDBLK)

      RETURN
      END SUBROUTINE SETMIX

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!   Copyright by The HDF Group.                                               *
!   Copyright by the Board of Trustees of the University of Illinois.         *
!   All rights reserved.                                                      *
!                                                                             *
!   This file is part of HDF5.  The full HDF5 copyright notice, including     *
!   terms governing use, modification, and redistribution, is contained in    *
!   the files COPYING and Copyright.html.  COPYING can be found at the root   *
!   of the source code distribution tree; Copyright.html can be found at the  *
!   root level of an installed copy of the electronic HDF5 document set and   *
!   is linked from the top-level documents page.  It can also be found at     *
!   http://hdfgroup.org/HDF5/doc/Copyright.html.  If you do not have          *
!   access to either file, you may request a copy from help@hdfgroup.org.     *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

!//////////////////////////////////////////////////////////
! main program for parallel HDF5 Fortran tests
!//////////////////////////////////////////////////////////

PROGRAM parallel_test
  USE hdf5
  IMPLICIT NONE
  INCLUDE 'mpif.h'

  INTEGER :: mpierror                             ! MPI hdferror flag
  INTEGER :: hdferror                             ! HDF hdferror flag
  LOGICAL :: do_collective                        ! use collective MPI I/O
  LOGICAL :: do_chunk                             ! use chunking
  INTEGER :: nerrors = 0                          ! number of errors
  INTEGER :: mpi_size                             ! number of processes in the group of communicator
  INTEGER :: mpi_rank                             ! rank of the calling process in the communicator
  INTEGER :: length = 12000                       ! length of array

  !//////////////////////////////////////////////////////////
  ! initialize MPI
  !//////////////////////////////////////////////////////////

  CALL mpi_init(mpierror)
  IF (mpierror .NE. MPI_SUCCESS) THEN
     WRITE(*,*) "MPI_INIT  *FAILED*"
  ENDIF
  CALL mpi_comm_rank( MPI_COMM_WORLD, mpi_rank, mpierror )
  IF (mpierror .NE. MPI_SUCCESS) THEN
     WRITE(*,*) "MPI_COMM_RANK  *FAILED* Process = ", mpi_rank
  ENDIF
  CALL mpi_comm_size( MPI_COMM_WORLD, mpi_size, mpierror )
  IF (mpierror .NE. MPI_SUCCESS) THEN
     WRITE(*,*) "MPI_COMM_SIZE  *FAILED* Process = ", mpi_rank
  ENDIF
  !//////////////////////////////////////////////////////////
  ! initialize the HDF5 fortran interface
  !//////////////////////////////////////////////////////////

  CALL h5open_f(hdferror)

  !//////////////////////////////////////////////////////////
  ! test write/read dataset by hyperslabs with independent MPI I/O
  !//////////////////////////////////////////////////////////

  IF (mpi_rank == 0) WRITE(*,*) 'Writing/reading dataset by hyperslabs (contiguous layout, independent MPI I/O)'

  do_collective = .FALSE.
  do_chunk      = .FALSE.
  CALL hyper(length, do_collective, do_chunk, mpi_size, mpi_rank, nerrors)

  !//////////////////////////////////////////////////////////
  ! test write/read dataset by hyperslabs with collective MPI I/O
  !//////////////////////////////////////////////////////////

  IF (mpi_rank == 0) WRITE(*,*) 'Writing/reading dataset by hyperslabs (contiguous layout, collective MPI I/O)'

  do_collective = .TRUE.
  do_chunk      = .FALSE.
  CALL hyper(length, do_collective, do_chunk, mpi_size, mpi_rank, nerrors)

  !//////////////////////////////////////////////////////////
  ! test write/read dataset by hyperslabs with independent MPI I/O
  !//////////////////////////////////////////////////////////

  IF (mpi_rank == 0) WRITE(*,*) 'Writing/reading dataset by hyperslabs (chunk layout, independent MPI I/O)'

  do_collective = .FALSE.
  do_chunk      = .TRUE.
  CALL hyper(length, do_collective, do_chunk, mpi_size, mpi_rank, nerrors)

  !//////////////////////////////////////////////////////////
  ! test write/read dataset by hyperslabs with collective MPI I/O
  !//////////////////////////////////////////////////////////

  IF (mpi_rank == 0) WRITE(*,*) 'Writing/reading dataset by hyperslabs (chunk layout, collective MPI I/O)'

  do_collective = .TRUE.
  do_chunk      = .TRUE.
  CALL hyper(length, do_collective, do_chunk, mpi_size, mpi_rank, nerrors)

  !//////////////////////////////////////////////////////////
  ! test write/read several datasets (independent MPI I/O)
  !//////////////////////////////////////////////////////////

  IF (mpi_rank == 0) WRITE(*,*) 'Writing/reading several datasets (contiguous layout, independent MPI I/O)'

  do_collective = .FALSE.
  do_chunk      = .FALSE.
  CALL multiple_dset_write(length, do_collective, do_chunk, mpi_size, mpi_rank, nerrors)

  !//////////////////////////////////////////////////////////
  ! close HDF5 interface
  !//////////////////////////////////////////////////////////

  CALL h5close_f(hdferror)

  !//////////////////////////////////////////////////////////
  ! close MPI
  !//////////////////////////////////////////////////////////

  IF (nerrors == 0) THEN
     CALL mpi_finalize(mpierror)
     IF (mpierror .NE. MPI_SUCCESS) THEN
        WRITE(*,*) "MPI_FINALIZE  *FAILED* Process = ", mpi_rank
     ENDIF
  ELSE
     WRITE(*,*) 'Errors detected in process ', mpi_rank
     CALL mpi_abort(MPI_COMM_WORLD, 1, mpierror)
     IF (mpierror .NE. MPI_SUCCESS) THEN
        WRITE(*,*) "MPI_ABORT  *FAILED* Process = ", mpi_rank
     ENDIF
  ENDIF

  !//////////////////////////////////////////////////////////
  ! end main program
  !//////////////////////////////////////////////////////////

END PROGRAM parallel_test

max_stars_repo_name: pbasting/cactus

max_issues_repo_name: pbasting/cactus

max_forks_repo_name: pbasting/cactus


text:
      subroutine gwdenp(adwipp,bdwipp,jcsort,mlmrra,mosp,mrmlra,
     $ mwtsp,narn1,narn2,nstmax,qdwipp,rhoc,rhowc,tdsgks,tdsglw,
     $ tdspkc,tdsplc,tempc,vosol,wfh2o,wftds,wkgwi,woh2o,
     $ wosol,wotds)
c
c     This subroutine gets the weights of solute, total dissolved
c     solutes, and aqueous solution, and obtains the density of
c     the aqueous solution by evaluating the WIPP brine density
c     model. It also computes some related parameters, such
c     as the solution volume and the molarity/molality ratio.
c
c     This subroutine is called by:
c
c       EQ3NR/eq3nr.f
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       adwipp = 'a' constant in the WIPP brine density model
c       bdwipp = 'b' constant in the WIPP brine density model
c       jcsort = array of species indices in order of increasing
c                  concentration, organized into blocks, one per phase
c       mosp   = numbers of moles of species
c       mwtsp  = molecular weights of species
c       mwtsp  = molecular weights of species
c
c     Principal output:
c
c       mlmrra = molality/molarity ratio
c       mrmlra = molarity/molality ratio
c       qdwipp = .true. if results from the WIPP brine density model
c                  are available
c       rhoc   = the solution density (g/mL), calculated from the WIPP
c                  brine density model
c       rhowc  = the solution density (g/L), calculated from the WIPP
c                  brine density model
c       tdsglw = TDS (total dissolved solutes) (g/L), calculated
c                  from the WIPP brine density model
c       tdsgks = TDS (total dissolved solutes) (g/kg.sol)
c       tdspkc = TDS (total dissolved solutes) (mg/kg.sol)
c       tdsplc = TDS (total dissolved solutes) (mg/L), calculated
c                  from the WIPP brine density model
c       vosol  = Volume (L) of aqueous solution
c       wfh2o  = weight (mass) fraction of water in aqueous solution
c       wftds  = weight (mass) fraction of solutes in aqueous solution
c       woh2o  = weight (mass) of solvent water
c       wosol  = weight (mass) of aqueous solution
c       wotds  = weight (mass) of total dissolved solutes
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nstmax
c
      integer jcsort(nstmax)
c
      integer narn1,narn2
c
      logical qdwipp
c
      real(8) mosp(nstmax),mwtsp(nstmax)
c
      real(8) adwipp,bdwipp,mlmrra,mrmlra,rhoc,rhowc,tdsgks,tdsglw,
     $ tdspkc,tdsplc,tempc,vosol,wfh2o,wftds,wkgwi,woh2o,wosol,wotds
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
c     None
c
c-----------------------------------------------------------------------
c
c     Calculate the weights (actually, the masses) of total dissolved
c     solutes, the solvent, and the solution, and also some related
c     quantities.
c
c     Get the total dissolved solute mass (wotds, g).
c
      call ctds(jcsort,mosp,mwtsp,narn1,narn2,nstmax,wotds)
c
c     Get the solvent mass (fixed at 1000 grams in EQ3NR, variable
c     in EQ6). The following works for either code.
c
      woh2o = mosp(narn1)*mwtsp(narn1)
c
c     Get the mass of aqueous solution.
c
      wosol =  woh2o + wotds
c
c     Get the weight fraction of solvent and the weight fraction
c     of total dissolved solutes.
c
      wfh2o = woh2o/wosol
      wftds = wotds/wosol
c
c     Get the inverse of the weight of solvent, in kg.
c
      wkgwi = 1000./woh2o
c
c     Get the TDS (g/kg.solution)
c
      tdsgks = 1000.*wftds
c
c     Get the TDS (mg/kg.solution)
c
      tdspkc = 1000.*tdsgks
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Calculate the solution density (rhowc) from the WIPP brine
c     density model if the temperature lies in the range 20-30 C.
c     This model is a fit to NaCl solution data having the form:
c
c       density (g/L) = a + b x TDS (g/L)
c
c     where a = 1000.96 and b = 0.639963. Note that this formulation
c     requires knowing TDS in g/L (tdsglw), which prevents a direct
c     evaluation using the above form because the density is not
c     available in the appropriate units. Also calculate the molarity/
c     molality conversion ratio (mrmlra, molarity = mrmlra x molality)
c     and its inverse.
c
      qdwipp = .false.
      rhowc = 0.
      vosol = 0.
      tdsglw = 0.
      mrmlra = 0.
      mlmrra = 0.
      rhoc = 0.
      tdsplc = 0.
c
      if (tempc.ge.20. .and. tempc.le.30.) then
c
c       Note that wfh2o corresponds to Nw, the "solvent fraction"
c       in the density calculations writeup. Here wftds corresponds
c       to "(1 - Nw)".
c
        qdwipp = .true.
        rhowc = adwipp/(1.0 - bdwipp*wftds)
        vosol = wosol/rhowc
        tdsglw = rhowc*wftds
        mrmlra = 0.001*wfh2o*rhowc
        if (mrmlra .gt. 0.) then
          mlmrra = 1./mrmlra
        else
          mlmrra = 1.e+38
        endif
        rhoc = 0.001*rhowc
        tdsplc = 1000.*tdsglw
      endif
c
  999 continue
      end