text:
      PROGRAM FM080

C     COMMENT SECTION                                                   00010080
C                                                                       00020080
C     FM080                                                             00030080
C                                                                       00040080
C         THIS ROUTINE CONTAINS EXTERNAL FUNCTION REFERENCE TESTS.      00050080
C     THE FUNCTION SUBPROGRAMS CALLED BY THIS ROUTINE ARE FF081,        00060080
C     FF082 AND FF083.  THE FUNCTION SUBPROGRAMS ARE DEFINED AS         00070080
C     FF081 = INTEGER, FF082 = REAL, FF083 = IMPLICIT REAL.             00080080
C     THE FUNCTION SUBPROGRAM DUMMY ARGUMENTS MUST AGREE IN ORDER,      00090080
C     NUMBER AND TYPE WITH THE CORRESPONDING ACTUAL ARGUMENTS OF THE    00100080
C     MAIN PROGRAM.     THE ARGUMENTS OF THE FUNCTION SUBPROGRAMS WILL  00110080
C     CORRESPOND TO ACTUAL ARGUMENT LIST REFERENCES OF VARIABLE-NAME,   00120080
C     ARRAY-NAME, ARRAY-ELEMENT-NAME AND EXPRESSION RESPECTIVELY.       00130080
C                                                                       00140080
C         THIS ROUTINE WILL TEST THE VALUE OF THE FUNCTION AND THE      00150080
C     FUNCTION ARGUMENTS RETURNED FOLLOWING THE FUNCTION REFERENCE CALL.00160080
C                                                                       00170080
C                                                                       00180080
C      REFERENCES                                                       00190080
C        AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN,       00200080
C              X3.9-1978                                                00210080
C                                                                       00220080
C        SECTION 2.6, ARRAY                                             00230080
C        SECTION 15.5.2, REFERENCING EXTERNAL FUNCTIONS                 00240080
C        SECTION 17.2, EVENTS THAT CAUSE ENTITIES TO BECOME DEFINED     00250080
      DIMENSION  IADN1A (5),   IADN2A (4,4)                             00260080
      DIMENSION RADN3A (3,6,3), RADN1A (10)                             00270080
      DIMENSION IADN3A (3,4,5)                                          00280080
      INTEGER FF081                                                     00290080
      REAL FF082                                                        00300080
C                                                                       00310080
C      **********************************************************       00320080
C                                                                       00330080
C         A COMPILER VALIDATION SYSTEM FOR THE FORTRAN LANGUAGE         00340080
C     BASED ON SPECIFICATIONS AS DEFINED IN AMERICAN NATIONAL STANDARD  00350080
C     PROGRAMMING LANGUAGE FORTRAN X3.9-1978, HAS BEEN DEVELOPED BY THE 00360080
C     FEDERAL COBOL COMPILER TESTING SERVICE.  THE FORTRAN COMPILER     00370080
C     VALIDATION SYSTEM (FCVS) CONSISTS OF AUDIT ROUTINES, THEIR RELATED00380080
C     DATA, AND AN EXECUTIVE SYSTEM.  EACH AUDIT ROUTINE IS A FORTRAN   00390080
C     PROGRAM, SUBPROGRAM OR FUNCTION WHICH INCLUDES TESTS OF SPECIFIC  00400080
C     LANGUAGE ELEMENTS AND SUPPORTING PROCEDURES INDICATING THE RESULT 00410080
C     OF EXECUTING THESE TESTS.                                         00420080
C                                                                       00430080
C         THIS PARTICULAR PROGRAM/SUBPROGRAM/FUNCTION CONTAINS FEATURES 00440080
C     FOUND ONLY IN THE SUBSET AS DEFINED IN X3.9-1978.                 00450080
C                                                                       00460080
C         SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO -             00470080
C                                                                       00480080
C              NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY           00490080
C                   SOFTWARE STANDARDS VALIDATION GROUP                 00500080
C                          BUILDING 225  RM A266                        00510080
C                         GAITHERSBURG, MD  20899                       00520080
C      **********************************************************       00530080
C                                                                       00540080
C                                                                       00550080
C                                                                       00560080
C     INITIALIZATION SECTION                                            00570080
C                                                                       00580080
C     INITIALIZE CONSTANTS                                              00590080
C      **************                                                   00600080
C     I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER.         00610080
      I01 = 5                                                           00620080
C     I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER.             00630080
      I02 = 6                                                           00640080
C     SYSTEM ENVIRONMENT SECTION                                        00650080
C                                                                       00660080
CX010    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-010 CONTROL CARD. 00670080
C     THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5      00680080
C     (UNIT NUMBER FOR CARD READER).                                    00690080
CX011    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-011 CONTROL CARD. 00700080
C     THE CX011 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL            00710080
C     FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX010 ABOVE.         00720080
C                                                                       00730080
CX020    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-020 CONTROL CARD. 00740080
C     THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02 = 6      00750080
C     (UNIT NUMBER FOR PRINTER).                                        00760080
CX021    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-021 CONTROL CARD. 00770080
C     THE CX021 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL            00780080
C     FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX020 ABOVE.         00790080
C                                                                       00800080
      IVPASS=0                                                          00810080
      IVFAIL=0                                                          00820080
      IVDELE=0                                                          00830080
      ICZERO=0                                                          00840080
C                                                                       00850080
C     WRITE PAGE HEADERS                                                00860080
      WRITE (I02,90000)                                                 00870080
      WRITE (I02,90001)                                                 00880080
      WRITE (I02,90002)                                                 00890080
      WRITE (I02, 90002)                                                00900080
      WRITE (I02,90003)                                                 00910080
      WRITE (I02,90002)                                                 00920080
      WRITE (I02,90004)                                                 00930080
      WRITE (I02,90002)                                                 00940080
      WRITE (I02,90011)                                                 00950080
      WRITE (I02,90002)                                                 00960080
      WRITE (I02,90002)                                                 00970080
      WRITE (I02,90005)                                                 00980080
      WRITE (I02,90006)                                                 00990080
      WRITE (I02,90002)                                                 01000080
C                                                                       01010080
C     TEST SECTION                                                      01020080
C                                                                       01030080
C     EXTERNAL FUNCTION REFERENCE  -  FUNCTION SUBPROGRAM DEFINED AS    01040080
C                                     INTEGER (FF081)                   01050080
C                                                                       01060080
 6741 CONTINUE                                                          01070080
      IVTNUM = 674                                                      01080080
C                                                                       01090080
C         TEST 674 THROUGH 679 TEST THE FUNCTION AND ARGUMENT VALUES    01100080
C     FROM REFERENCE OF FUNCTION FF081.  FUNCTION SUBPROGRAM FF081 IS   01110080
C     DEFINED AS INTEGER.                                               01120080
C                                                                       01130080
C     **** TEST 674 ****                                                01140080
C                                                                       01150080
C     TEST 674 TESTS THE FUNCTION VALUE RETURNED FROM FUNCTION FF081    01160080
C                                                                       01170080
      IF (ICZERO) 36740,6740,36740                                      01180080
 6740 CONTINUE                                                          01190080
      IVON0A        = 0                                                 01200080
      IVON02        = 2                                                 01210080
      IADN1A (3)    = 8                                                 01220080
      IADN1A (2)    = 4                                                 01230080
      IADN2A (1,3)  =10                                                 01240080
      IVON0A = FF081 (IVON02, IADN1A, IADN2A, 999)                      01250080
      GO TO 46740                                                       01260080
36740 IVDELE =  IVDELE + 1                                              01270080
      WRITE (I02,80003) IVTNUM                                          01280080
      IF (ICZERO) 46740,6751,46740                                      01290080
46740 IF (IVON0A - 1015) 26740,16740,26740                              01300080
16740 IVPASS = IVPASS + 1                                               01310080
      WRITE (I02,80001) IVTNUM                                          01320080
      GO TO 6751                                                        01330080
26740 IVFAIL = IVFAIL + 1                                               01340080
      IVCORR = 1015                                                     01350080
      IVCOMP = IVON0A                                                   01360080
      WRITE  (I02,80004) IVTNUM, IVCOMP, IVCORR                         01370080
 6751 CONTINUE                                                          01380080
      IVTNUM = 675                                                      01390080
C                                                                       01400080
C     ****  TEST 675  ****                                              01410080
C                                                                       01420080
C         TEST 675 TESTS THE RETURN VALUE OF VARIABLE-NAME ARGUMENT     01430080
C     IVON02.   VALUE OF IVON02 SHOULD BE 4.                            01440080
C                                                                       01450080
      IF (ICZERO) 36750,6750,36750                                      01460080
 6750 CONTINUE                                                          01470080
      GO TO 46750                                                       01480080
36750 IVDELE = IVDELE + 1                                               01490080
      WRITE (I02,80003) IVTNUM                                          01500080
      IF (ICZERO) 46750,6761,46750                                      01510080
46750 IF (IVON02 - 4) 26750,16750,26750                                 01520080
16750 IVPASS = IVPASS + 1                                               01530080
      WRITE (I02,80001) IVTNUM                                          01540080
      GO TO 6761                                                        01550080
26750 IVFAIL = IVFAIL + 1                                               01560080
      IVCORR = 4                                                        01570080
      IVCOMP = IVON02                                                   01580080
      WRITE  (I02,80004) IVTNUM, IVCOMP, IVCORR                         01590080
 6761 CONTINUE                                                          01600080
      IVTNUM = 676                                                      01610080
C                                                                       01620080
C     ****  TEST 676  ****                                              01630080
C                                                                       01640080
C         TEST 676 TESTS THE RETURN VALUE OF ARRAY-NAME ARGUMENT        01650080
C     IADN1A.  IADN1A (2) IS INCREMENTED BY 40 IN FUNCTION SUBPROGRAM   01660080
C     AND SHOULD RETURN A VALUE OF 44.                                  01670080
C                                                                       01680080
      IF (ICZERO) 36760,6760,36760                                      01690080
 6760 CONTINUE                                                          01700080
      GO TO 46760                                                       01710080
36760 IVDELE = IVDELE + 1                                               01720080
      WRITE (I02,80003) IVTNUM                                          01730080
      IF (ICZERO) 46760,6771,46760                                      01740080
46760 IF (IADN1A (2) - 44) 26760,16760,26760                            01750080
16760 IVPASS = IVPASS + 1                                               01760080
      WRITE (I02,80001) IVTNUM                                          01770080
      GO TO 6771                                                        01780080
26760 IVFAIL = IVFAIL + 1                                               01790080
      IVCORR = 44                                                       01800080
      IVCOMP = IADN1A (2)                                               01810080
      WRITE  (I02,80004) IVTNUM, IVCOMP, IVCORR                         01820080
 6771 CONTINUE                                                          01830080
      IVTNUM = 677                                                      01840080
C                                                                       01850080
C     ****  TEST 677  ****                                              01860080
C                                                                       01870080
C        TEST 677 TESTS THE RETURN VALUE OF ARRAY-NAME ARGUMENT IADN1A. 01880080
C     IADN1A (3) WAS NOT MODIFFED    BY FUNCTION SUBPROGRAM AND SHOULD  01890080
C     HAVE A VALUE OF 8                                                 01900080
C                                                                       01910080
      IF (ICZERO) 36770,6770,36770                                      01920080
 6770 CONTINUE                                                          01930080
      GO TO 46770                                                       01940080
36770 IVDELE = IVDELE + 1                                               01950080
      WRITE (I02,80003) IVTNUM                                          01960080
      IF (ICZERO) 46770,6781,46770                                      01970080
46770 IF (IADN1A (3) - 8) 26770,16770,26770                             01980080
16770 IVPASS = IVPASS + 1                                               01990080
      WRITE (I02,80001) IVTNUM                                          02000080
      GO TO 6781                                                        02010080
26770 IVFAIL = IVFAIL + 1                                               02020080
      IVCORR = 8                                                        02030080
      IVCOMP = IADN1A (3)                                               02040080
      WRITE (I02,80004) IVTNUM, IVCOMP, IVCORR                          02050080
 6781 CONTINUE                                                          02060080
      IVTNUM = 678                                                      02070080
C                                                                       02080080
C     ****  TEST 678  ****                                              02090080
C                                                                       02100080
C         TEST 678 TESTS THE RETURN VALUE OF ARRAY-ELEMENT-NAME         02110080
C     IADN2A (1,3).  IADN2A (1,3) WAS INCREMENTED BY 70 IN THE FUNCTION 02120080
C     SUBPROGRAM AND SHOULD CONTAIN A VALUE OF 80.                      02130080
C                                                                       02140080
      IF (ICZERO) 36780,6780,36780                                      02150080
 6780 CONTINUE                                                          02160080
      GO TO 46780                                                       02170080
36780 IVDELE = IVDELE + 1                                               02180080
      WRITE  (I02,80003) IVTNUM                                         02190080
      IF (ICZERO) 46780,6791,46780                                      02200080
46780 IF (IADN2A (1,3) - 80) 26780,16780,26780                          02210080
16780 IVPASS = IVPASS + 1                                               02220080
      WRITE (I02,80001) IVTNUM                                          02230080
      GO TO 6791                                                        02240080
26780 IVFAIL = IVFAIL + 1                                               02250080
      IVCORR = 80                                                       02260080
      IVCOMP = IADN2A (1,3)                                             02270080
      WRITE (I02,80004) IVTNUM, IVCOMP, IVCORR                          02280080
 6791 CONTINUE                                                          02290080
      IVTNUM = 679                                                      02300080
C                                                                       02310080
C     ****  TEST 679  ****                                              02320080
C                                                                       02330080
C         TEST 679  TESTS THE VALUE OF INTEGER FUNCTION ASSIGNED        02340080
C     TO A REAL VARIABLE.                                               02350080
C                                                                       02360080
      IF (ICZERO) 36790,6790,36790                                      02370080
 6790 CONTINUE                                                          02380080
      RVON0A        = 0.0                                               02390080
      IVON02        = 2                                                 02400080
      IADN1A (2)    = 4                                                 02410080
      IADN2A (1,3)  = 10                                                02420080
      RVON0A = FF081 (IVON02, IADN1A, IADN2A, 999)                      02430080
      GO TO 46790                                                       02440080
36790 IVDELE = IVDELE + 1                                               02450080
      WRITE (I02,80003) IVTNUM                                          02460080
      IF (ICZERO) 46790,6801,46790                                      02470080
46790 IF (RVON0A - 1014.5) 26790,16790,46791                            02480080
46791 IF (RVON0A - 1015.5) 16790,16790,26790                            02490080
16790 IVPASS = IVPASS + 1                                               02500080
      WRITE (I02,80001) IVTNUM                                          02510080
      GO TO 6801                                                        02520080
26790 IVFAIL = IVFAIL + 1                                               02530080
      RVCORR = 1015.0                                                   02540080
      RVCOMP = RVON0A                                                   02550080
      WRITE  (I02,80005) IVTNUM, RVCOMP, RVCORR                         02560080
 6801 CONTINUE                                                          02570080
      IVTNUM = 680                                                      02580080
C                                                                       02590080
C     EXTERNAL FUNCTION REFERENCE - FUNCTION SUBPROGRAM FF082 DEFINED AS02600080
C                                   REAL                                02610080
C                                                                       02620080
C         TESTS 680 THRU 685  TESTS THE FUNCTION AND ARGUMENT VALUES    02630080
C     FROM THE FUNCTION REFERENCE TO SUBPROGRAM FF082. THE FUNCTION     02640080
C     SUBPROGRAM IS DEFINED AS REAL.                                    02650080
C                                                                       02660080
C     ****  TEST 680  ***                                               02670080
C                                                                       02680080
C         TEST  680  TESTS THE VALUE OF THE FUNCTION FF082. VALUE OF    02690080
C     FUNCTION SHOULD BE 339.0.                                         02700080
C                                                                       02710080
      IF  (ICZERO) 36800,6800,36800                                     02720080
 6800 CONTINUE                                                          02730080
      RVON01        =  2.0                                              02740080
      RADN3A (2,5,2) = 100.0                                            02750080
      RADN1A (5)   = 210.5                                              02760080
      RVON0A       = 0.0                                                02770080
      RVON0A = FF082 (RVON01, RADN3A, RADN1A, 26.5)                     02780080
      GO TO 46800                                                       02790080
36800 IVDELE = IVDELE + 1                                               02800080
      WRITE (I02, 80003) IVTNUM                                         02810080
      IF (ICZERO) 46800,6811,46800                                      02820080
46800 IF (RVON0A - 338.5) 26800,16800,46801                             02830080
46801 IF (RVON0A - 339.5) 16800,16800,26800                             02840080
16800 IVPASS = IVPASS + 1                                               02850080
      WRITE (I02,80001) IVTNUM                                          02860080
      GO TO 6811                                                        02870080
26800 IVFAIL = IVFAIL + 1                                               02880080
      RVCORR = 339.0                                                    02890080
      RVCOMP = RVON0A                                                   02900080
      WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR                          02910080
 6811 CONTINUE                                                          02920080
      IVTNUM = 681                                                      02930080
C                                                                       02940080
C     **** TEST 681  ****                                               02950080
C                                                                       02960080
C         TEST 681 TESTS THE VALUE OF THE VARIABLE-NAME ARGUMENT RVON01 02970080
C     FOLLOWING THE FUNCTION REFERENCE.  VALUE OF RVON01 SHOULD BE 8.4. 02980080
C                                                                       02990080
      IF (ICZERO) 36810,6810,36810                                      03000080
 6810 CONTINUE                                                          03010080
      GO TO 46810                                                       03020080
36810 IVDELE = IVDELE + 1                                               03030080
      WRITE (I02,80003) IVTNUM                                          03040080
      IF (ICZERO) 46810,6821,46810                                      03050080
46810 IF (RVON01 - 8.395) 26810,16810,46811                             03060080
46811 IF (RVON01 - 8.405) 16810,16810,26810                             03070080
16810 IVPASS = IVPASS + 1                                               03080080
      WRITE (I02,80001) IVTNUM                                          03090080
      GO TO 6821                                                        03100080
26810 IVFAIL = IVFAIL + 1                                               03110080
      RVCORR = 8.4                                                      03120080
      RVCOMP = RVON01                                                   03130080
      WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR                          03140080
 6821 CONTINUE                                                          03150080
      IVTNUM = 682                                                      03160080
C                                                                       03170080
C     ****  TEST 682  ****                                              03180080
C                                                                       03190080
C         TEST 682 TESTS THE VALUE OF THE ARRAY-NAME ARGUMENT RADN3A    03200080
C     FOLLOWING THE FUNCTION REFERENCE. RADN3A (2,5,2) WAS INITIALIZED  03210080
C     IN MAIN PROGRAM AND INCREMENTED IN SUBPROGRAM. VALUE OF RADN3A    03220080
C     (2,5,2) SHOULD BE 112.2.                                          03230080
C                                                                       03240080
      IF (ICZERO) 36820,6820,36820                                      03250080
 6820 CONTINUE                                                          03260080
      GO TO 46820                                                       03270080
36820 IVDELE = IVDELE + 1                                               03280080
      WRITE (I02,80003) IVTNUM                                          03290080
      IF (ICZERO) 46820,6831,46820                                      03300080
46820 IF (RADN3A (2,5,2) - 111.7) 26820,16820,46821                     03310080
46821 IF (RADN3A (2,5,2) - 112.7) 16820,16820,26820                     03320080
16820 IVPASS = IVPASS + 1                                               03330080
      WRITE (I02,80001) IVTNUM                                          03340080
      GO TO 6831                                                        03350080
26820 IVFAIL = IVFAIL + 1                                               03360080
      RVCORR = 112.2                                                    03370080
      RVCOMP = RADN3A (2,5,2)                                           03380080
      WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR                          03390080
 6831 CONTINUE                                                          03400080
      IVTNUM = 683                                                      03410080
C                                                                       03420080
C     ****  TEST 683  ****                                              03430080
C                                                                       03440080
C         TEST 683 TESTS  THE VALUE OF THE ARRAY-NAME ARGUMENT RADN3A   03450080
C     FOLLOWING THE FUNCTION REFERENCE.  RADN3A (1,2,1) WAS INITIALIZED 03460080
C     IN THE SUBPROGRAM. THE VALUE OF RADN3A (1,2,1) SHOULD BE 612.2.   03470080
C                                                                       03480080
      IF (ICZERO) 36830,6830,36830                                      03490080
 6830 CONTINUE                                                          03500080
      GO TO 46830                                                       03510080
36830 IVDELE = IVDELE + 1                                               03520080
      WRITE (I02,80003) IVTNUM                                          03530080
      IF (ICZERO) 46830,6841,46830                                      03540080
46830 IF (RADN3A (1,2,1) - 611.7) 26830,16830,46831                     03550080
46831 IF (RADN3A (1,2,1) - 612.7) 16830,16830,26830                     03560080
16830 IVPASS = IVPASS + 1                                               03570080
      WRITE (I02,80001) IVTNUM                                          03580080
      GO TO 6841                                                        03590080
26830 IVFAIL = IVFAIL + 1                                               03600080
      RVCORR = 612.2                                                    03610080
      RVCOMP = RADN3A (1,2,1)                                           03620080
      WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR                          03630080
 6841 CONTINUE                                                          03640080
      IVTNUM = 684                                                      03650080
C                                                                       03660080
C     ****  TEST 684  ****                                              03670080
C                                                                       03680080
C         TEST 684 TESTS THE VALUE OF THE ARRAY-ELEMENT-NAME ARGUMENT   03690080
C     RADN1A FOLLOWING THE FUNCTION REFERENCE. RADN1A (5) WAS           03700080
C     INITIALIZED IN THE MAIN PROGRAM AND INCREMENTED BY 18.8 IN THE    03710080
C     FUNCTION SUBPROGRAM.  THE VALUE OF RADN1A SHOULD BE 229.3.        03720080
C                                                                       03730080
      IF (ICZERO) 36840,6840,36840                                      03740080
 6840 CONTINUE                                                          03750080
      GO TO 46840                                                       03760080
36840 IVDELE = IVDELE + 1                                               03770080
      WRITE (I02,80003) IVTNUM                                          03780080
      IF (ICZERO) 46840,6851,46840                                      03790080
46840 IF (RADN1A (5) - 228.8) 26840,16840,46841                         03800080
46841 IF (RADN1A (5) - 229.8) 16840,16840,26840                         03810080
16840 IVPASS = IVPASS + 1                                               03820080
      WRITE (I02,80001) IVTNUM                                          03830080
      GO TO 6851                                                        03840080
26840 IVFAIL = IVFAIL + 1                                               03850080
      RVCORR = 229.3                                                    03860080
      RVCOMP = RADN1A (5)                                               03870080
      WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR                          03880080
 6851 CONTINUE                                                          03890080
      IVTNUM = 685                                                      03900080
C                                                                       03910080
C     **** TEST 685 ****                                                03920080
C                                                                       03930080
C         TEST 685  TESTS THE RESULTANT VALUE WHERE THE FUNCTION        03940080
C     SUBPROGRAM IS DEFINED AS REAL AND THE VARIABLE TO WHICH THE       03950080
C     FUNCTION VALUE IS ASSIGNED IN THE MAIN PROGRAM IS DEFINED AS      03960080
C     INTEGER.                                                          03970080
C                                                                       03980080
      IF (ICZERO) 36850,6850,36850                                      03990080
 6850 CONTINUE                                                          04000080
      RVON01   = 4.0                                                    04010080
      RADN3A (2,5,2) = 200.0                                            04020080
      RADN1A (5) = 2.85                                                 04030080
      IVON0A = 0.0                                                      04040080
      IVON0A = FF082 (RVON01, RADN3A, RADN1A, 102.68)                   04050080
      GO TO 46850                                                       04060080
36850 IVDELE = IVDELE + 1                                               04070080
      WRITE (I02,80003) IVTNUM                                          04080080
      IF (ICZERO) 46850,6861,46850                                      04090080
46850 IF (IVON0A - 309)    26850,16850,26850                            04100080
16850 IVPASS = IVPASS + 1                                               04110080
      WRITE (I02,80001) IVTNUM                                          04120080
      GO TO 6861                                                        04130080
26850 IVFAIL = IVFAIL + 1                                               04140080
      IVCORR = 309                                                      04150080
      IVCOMP = IVON0A                                                   04160080
      WRITE (I02,80004) IVTNUM, IVCOMP, IVCORR                          04170080
 6861 CONTINUE                                                          04180080
      IVTNUM = 686                                                      04190080
C                                                                       04200080
C         TESTS 686 THRU 690 TESTS THE FUNCTION AND ARGUMENT VALUES     04210080
C     FROM THE EXTERNAL FUNCTION REFERENCE TO SUBPROGRAM FF083. THE     04220080
C     FUNCTION SUBPROGRAM IS AN IMPLICIT DEFINITION OF REAL.            04230080
C                                                                       04240080
C     *****  TEST 686  *****                                            04250080
C                                                                       04260080
C         TEST 686 TESTS THE VALUE OF FUNCTION FF082. THE VALUE OF THE  04270080
C     FUNCTION SHOULD BE 921.8.                                         04280080
C                                                                       04290080
      IF (ICZERO) 36860,6860,36860                                      04300080
 6860 CONTINUE                                                          04310080
C                                                                       04320080
C                                                                       04330080
      IVON01 =  826                                                     04340080
      IADN2A (1,1) = 77                                                 04350080
      IADN3A (2,3,4) =  10                                              04360080
      RVON02 = 4.4                                                      04370080
      RVON03 = 0.0                                                      04380080
C                                                                       04390080
      RVON03 = FF083 (IVON01, IADN2A, IADN3A, RVON02 * 2.0)             04400080
      GO TO 46860                                                       04410080
36860 IVDELE = IVDELE + 1                                               04420080
      WRITE (I02,80003) IVTNUM                                          04430080
      IF (ICZERO) 46860,6871,46860                                      04440080
46860 IF (RVON03 - 921.3) 26860,16860,46861                             04450080
46861 IF (RVON03 - 922.3) 16860,16860,26860                             04460080
16860 IVPASS = IVPASS + 1                                               04470080
      WRITE (I02,80001) IVTNUM                                          04480080
      GO TO 6871                                                        04490080
26860 IVFAIL = IVFAIL + 1                                               04500080
      RVCORR = 921.8                                                    04510080
      RVCOMP = RVON03                                                   04520080
      WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR                          04530080
 6871 CONTINUE                                                          04540080
      IVTNUM = 687                                                      04550080
C                                                                       04560080
C     ****  TEST  687  *****                                            04570080
C                                                                       04580080
C         TEST 687 TESTS THE VALUE OF THE VARIABLE-NAME ARGUMENT IVON01 04590080
C     FOLLOWING THE FUNCTION REFERENCE. THE VALUE OF IVON01 SHOULD BE   04600080
C     836.                                                              04610080
C                                                                       04620080
      IF (ICZERO) 36870,6870,36870                                      04630080
 6870 CONTINUE                                                          04640080
      GO TO 46870                                                       04650080
36870 IVDELE = IVDELE + 1                                               04660080
      WRITE (I02,80003) IVTNUM                                          04670080
      IF (ICZERO) 46870,6881,46870                                      04680080
46870 IF (IVON01 - 836) 26870,16870,26870                               04690080
16870 IVPASS = IVPASS + 1                                               04700080
      WRITE (I02,80001) IVTNUM                                          04710080
      GO TO 6881                                                        04720080
26870 IVFAIL = IVFAIL + 1                                               04730080
      IVCORR = 836                                                      04740080
      IVCOMP = IVON01                                                   04750080
      WRITE (I02,80004) IVTNUM, IVCOMP, IVCORR                          04760080
 6881 CONTINUE                                                          04770080
      IVTNUM = 688                                                      04780080
C                                                                       04790080
C     ****  TEST 688  *****                                             04800080
C                                                                       04810080
C         TEST 688 TESTS THE VALUE OF THE ARRAY-NAME ARGUMENT IADN2A    04820080
C     FOLLOWING THE FUNCTION REFERENCE. THE ACTUAL ARGUMENT WAS         04830080
C     INITIALIZED IN THE MAIN PROGRAM AND IS INCREMENTED IN THE         04840080
C     SUBPROGRAM. THE VALUE OF IADN2A (1,1) SHOULD BE 97.               04850080
C                                                                       04860080
      IF (ICZERO) 36880,6880,36880                                      04870080
 6880 CONTINUE                                                          04880080
      GO TO 46880                                                       04890080
36880 IVDELE = IVDELE + 1                                               04900080
      WRITE  (I02,80003) IVTNUM                                         04910080
      IF (ICZERO) 46880,6880,46880                                      04920080
46880 IF (IADN2A (1,1) - 97) 26880,16880,26880                          04930080
16880 IVPASS = IVPASS + 1                                               04940080
      WRITE (I02,80001) IVTNUM                                          04950080
      GO TO 6891                                                        04960080
26880 IVFAIL = IVFAIL + 1                                               04970080
      IVCORR = 97                                                       04980080
      IVCOMP = IADN2A (1,1)                                             04990080
      WRITE (I02,80004) IVTNUM, IVCOMP, IVCORR                          05000080
 6891 CONTINUE                                                          05010080
      IVTNUM = 689                                                      05020080
C                                                                       05030080
C     **** TEST 689 ****                                                05040080
C                                                                       05050080
C         TEST 689 TESTS THE VALUE OF THE ARRAY-ELEMENT-NAME ARGUMENT   05060080
C     IADN3A FOLLOWING THE FUNCTION REFERENCE.  IADN3A (2,3,4)          05070080
C     WAS INTIALIZED IN THE MAIN PROGRAM AND INCREMENTED BY 40 IN THE   05080080
C     FUNCTION SUBPROGRAM. THE VALUE OF IADN3A SHOULD BE 50.            05090080
C                                                                       05100080
      IF (ICZERO) 36890,6890,36890                                      05110080
 6890 CONTINUE                                                          05120080
      GO TO 46890                                                       05130080
36890 IVDELE = IVDELE + 1                                               05140080
      WRITE (I02,80003) IVTNUM                                          05150080
      IF (ICZERO) 46890,6901,46890                                      05160080
46890 IF (IADN3A (2,3,4) - 50) 26890,16890,26890                        05170080
16890 IVPASS = IVPASS + 1                                               05180080
      WRITE (I02,80001) IVTNUM                                          05190080
      GO TO 6901                                                        05200080
26890 IVFAIL = IVFAIL + 1                                               05210080
      IVCORR = 50                                                       05220080
      IVCOMP = IADN3A (2,3,4)                                           05230080
      WRITE (I02,80004) IVTNUM,IVCOMP,IVCORR                            05240080
 6901 CONTINUE                                                          05250080
      IVTNUM = 690                                                      05260080
C                                                                       05270080
C     **** TEST 690  ****                                               05280080
C                                                                       05290080
C         TEST  690 TESTS THE RESULTANT VALUE WHERE THE FUNCTION        05300080
C     SUBPROGRAM IS IMPLICITY DEFINED AS REAL AND THE VARIABLE          05310080
C     TO WHICH THE FUNCTION VALUE IS ASSIGNED IN THE MAIN PROGRAM       05320080
C     IS DEFINED AS INTEGER. THE VALUE OF IVON03 SHOULD BE 329.         05330080
C                                                                       05340080
      IF (ICZERO) 36900,6900,36900                                      05350080
 6900 CONTINUE                                                          05360080
      IVON01 =   226                                                    05370080
      IADN2A (1,1) = 66                                                 05380080
      IADN3A (2,3,4) = 20                                               05390080
      RVON02 = 8.8                                                      05400080
      IVON03 = 0                                                        05410080
C                                                                       05420080
      IVON03 = FF083 (IVON01,IADN2A,IADN3A,RVON02 * 2.0)                05430080
C                                                                       05440080
      GO TO 46900                                                       05450080
36900 IVDELE = IVDELE + 1                                               05460080
      WRITE (I02,80003) IVTNUM                                          05470080
      IF (ICZERO) 46900,6911,46900                                      05480080
46900 IF (IVON03 - 329) 26900,16900,26900                               05490080
16900 IVPASS = IVPASS + 1                                               05500080
      WRITE (I02,80001) IVTNUM                                          05510080
      GO TO 6911                                                        05520080
26900 IVFAIL = IVFAIL + 1                                               05530080
      IVCORR = 329                                                      05540080
      IVCOMP = IVON03                                                   05550080
      WRITE (I02,80004) IVTNUM, IVCOMP, IVCORR                          05560080
 6911 CONTINUE                                                          05570080
C                                                                       05580080
C     WRITE PAGE FOOTINGS AND RUN SUMMARIES                             05590080
99999 CONTINUE                                                          05600080
      WRITE (I02,90002)                                                 05610080
      WRITE (I02,90006)                                                 05620080
      WRITE (I02,90002)                                                 05630080
      WRITE (I02,90002)                                                 05640080
      WRITE (I02,90007)                                                 05650080
      WRITE (I02,90002)                                                 05660080
      WRITE (I02,90008)  IVFAIL                                         05670080
      WRITE (I02,90009) IVPASS                                          05680080
      WRITE (I02,90010) IVDELE                                          05690080
C                                                                       05700080
C                                                                       05710080
C     TERMINATE ROUTINE EXECUTION                                       05720080
      STOP                                                              05730080
C                                                                       05740080
C     FORMAT STATEMENTS FOR PAGE HEADERS                                05750080
90000 FORMAT ("1")                                                      05760080
90002 FORMAT (" ")                                                      05770080
90001 FORMAT (" ",10X,"FORTRAN COMPILER VALIDATION SYSTEM" )            05780080
90003 FORMAT (" ",21X,"VERSION 2.1" )                                   05790080
90004 FORMAT (" ",10X,"FOR OFFICIAL USE ONLY - COPYRIGHT 1978" )        05800080
90005 FORMAT (" ",5X,"TEST",5X,"PASS/FAIL", 5X,"COMPUTED",8X,"CORRECT") 05810080
90006 FORMAT (" ",5X,"----------------------------------------------" ) 05820080
90011 FORMAT (" ",18X,"SUBSET LEVEL TEST" )                             05830080
C                                                                       05840080
C     FORMAT STATEMENTS FOR RUN SUMMARIES                               05850080
90008 FORMAT (" ",15X,I5," ERRORS ENCOUNTERED" )                        05860080
90009 FORMAT (" ",15X,I5," TESTS PASSED" )                              05870080
90010 FORMAT (" ",15X,I5," TESTS DELETED" )                             05880080
C                                                                       05890080
C     FORMAT STATEMENTS FOR TEST RESULTS                                05900080
80001 FORMAT (" ",4X,I5,7X,"PASS")                                      05910080
80002 FORMAT (" ",4X,I5,7X,"FAIL")                                      05920080
80003 FORMAT (" ",4X,I5,7X,"DELETED")                                   05930080
80004 FORMAT (" ",4X,I5,7X,"FAIL",10X,I6,9X,I6)                         05940080
80005 FORMAT (" ",4X,I5,7X,"FAIL",4X,E12.5,3X,E12.5)                    05950080
C                                                                       05960080
90007 FORMAT (" ",20X,"END OF PROGRAM FM080" )                          05970080
      END                                                               05980080

      INTEGER FUNCTION FF081 (IDON01, IDDN10, IDDN20, IDON02)           00010081
C                                                                       00020081
C     COMMENT SECTION                                                   00030081
C                                                                       00040081
C     FF081                                                             00050081
C                                                                       00060081
C         THIS FUNCTION SUBPROGRAM IS CALLED BY THE MAIN PROGRAM FM080. 00070081
C     THE FUNCTION DUMMY ARGUMENTS IDON01, IDDN10 AND IDDN20 ARE        00080081
C     INCREMENTED BY 2, 40 AND 70 RESPECTIVELY BEFORE CONTROL IS        00090081
C     RETURNED TO THE CALLING PROGRAM.  VALUE OF THE FUNCTION WILL BE   00100081
C     THE SUM OF THE ACTUAL ARGUMENTS AS PASSED FROM CALLING PROGRAM.   00110081
C                                                                       00120081
C      REFERENCES                                                       00130081
C        AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN,       00140081
C              X3.9-1978                                                00150081
C                                                                       00160081
C        SECTION 15.5.1, FUNCTION SUBPROGRAM AND FUNCTION STATEMENT     00170081
C                                                                       00180081
C     TEST SECTION                                                      00190081
C                                                                       00200081
C         FUNCTION SUBPROGRAM                                           00210081
C                                                                       00220081
      DIMENSION  IDDN10 (5),   IDDN20 (4,4)                             00230081
      IVON01 = IDON01                                                   00240081
      IVON02 = IDDN10(2)                                                00250081
      IVON03 = IDDN20(1,3)                                              00260081
      IVON04 = IDON02                                                   00270081
C                                                                       00280081
      FF081  = IVON01 + IVON02 + IVON03 + IVON04                        00290081
      IDON01 = IVON01 + 2                                               00300081
      IDDN10 (2) = IVON02   + 40                                        00310081
      IDDN20 (1,3) = IVON03 + 70                                        00320081
      IDDN10 (4) = IVON02 + 40                                          00330081
      RETURN                                                            00340081
      END                                                               00350081

      REAL FUNCTION FF082 (RDON01, RDDN3A, RDDN1A, RDON02)              00010082
      DIMENSION  RDDN3A (3,6,3), RDDN1A (10)                            00020082
C                                                                       00030082
C     COMMENT SECTION                                                   00040082
C                                                                       00050082
C     FF082                                                             00060082
C                                                                       00070082
C         THIS FUNCTION SUBPROGRAM IS CALLED BY THE MAIN PROGRAM FM080. 00080082
C     THE FUNCTION DUMMY ARGUMENTS RDON01, RDDN3A, AND RDDN1A ARE       00090082
C     INCREMENTED BY 6.4, 12.2 AND 18.8 RESPECTIVELY BEFORE CONTROL IS  00100082
C     RETURNED TO THE MAIN PROGRAM.  VALUE OF THE FUNCTION WILL BE      00110082
C     THE SUM OF THE ACTUAL ARGUMENTS AS PASSED TO THE SUBPROGRAM.      00120082
C                                                                       00130082
C      REFERENCES                                                       00140082
C        AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN,       00150082
C              X3.9-1978                                                00160082
C                                                                       00170082
C        SECTION 15.5.1, FUNCTION SUBPROGRAM AND FUNCTION STATEMENT     00180082
C                                                                       00190082
C     TEST SECTION                                                      00200082
C                                                                       00210082
C          FUNCTION SUBPROGRAM                                          00220082
C                                                                       00230082
      RVON01 = RDON01                                                   00240082
      RVON02 = RDDN3A (2,5,2)                                           00250082
      RVON03 = RDDN1A (5)                                               00260082
      RVON04 = RDON02                                                   00270082
C                                                                       00280082
      FF082 = RVON01 + RVON02 + RVON03  + RVON04                        00290082
C                                                                       00300082
      RDON01 =     RVON01 + 6.4                                         00310082
      RDDN3A (2,5,2) = RVON02 + 12.2                                    00320082
      RDDN1A (5)     = RVON03 + 18.8                                    00330082
      RDDN3A (1,2,1) =  600.0 + 12.2                                    00340082
      RETURN                                                            00350082
      END                                                               00360082

      FUNCTION  FF083 (IDON01,IDDN2A,IDDN3A,RDON02)                     00010083
      DIMENSION  IDDN2A (2,2), IDDN3A(3,4,5)                            00020083
C                                                                       00030083
C     COMMENT SECTION                                                   00040083
C                                                                       00050083
C     FF083                                                             00060083
C                                                                       00070083
C         THIS FUNCTION SUBPROGRAM IS CALLED BY THE MAIN PROGRAM FM080. 00080083
C     THE TYPE DECLARATION IS IMPLICIT REAL.                            00090083
C     THE FUNCTION DUMMY ARGUMENTS ARE BOTH INTEGER AND REAL. DUMMY     00100083
C     ARGUMENTS IDON01, IDDN2A AND IDDN3A ARE INCREMENTED BY 10, 20 AND 00110083
C     40 RESPECTIVELY BEFORE CONTROL IS RETURNED TO THE MAIN PROGRAM.   00120083
C     THE VALUE OF THE FUNCTION RETURNED TO THE REFERENCING PROGRAM     00130083
C     WILL BE THE SUM OF THE ACTUAL ARGUMENTS AS PASSED TO THE          00140083
C     SUBPROGRAM FF083.                                                 00150083
C         DUMMY ARGUMENT IDDN2A CORRESPONDS TO AN ARRAY-NAME IN THE     00160083
C     ACTUAL ARGUMENT OF THE MAIN PROGRAM.  DUMMY ARGUMENT IDDN3A       00170083
C     CORRESPONDS TO AN ARRAY-ELEMENT-NAME IN THE ACTUAL ARGUMENT OF THE00180083
C     MAIN PROGRAM.  DUMMY ARGUMENT IDON02  CORRESPONDS TO AN EXPRESSION00190083
C     CONTAINING VARIABLES,ARITHMETIC OPERATORS AND CONSTANTS IN THE    00200083
C     ACTUAL ARGUMENT OF THE MAIN PROGRAM.                              00210083
C                                                                       00220083
C      REFERENCES                                                       00230083
C        AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN,       00240083
C              X3.9-1978                                                00250083
C                                                                       00260083
C        SECTION 4.1.2, TYPE RULES FOR DATA AND PROCEDURE IDENTIFIERS   00270083
C        SECTION 15.5.1, FUNCTION SUBPROGRAM                            00280083
C                                                                       00290083
C     TEST SECTION                                                      00300083
C                                                                       00310083
C          FUNCTION SUBPROGRAM                                          00320083
C                                                                       00330083
      IVON01 = IDON01                                                   00340083
      IVON02 = IDDN2A (1,1)                                             00350083
      IVON03 = IDDN3A (2,3,4)                                           00360083
      RVON04 = RDON02                                                   00370083
C                                                                       00380083
      RVON05 = IVON01 + IVON02 + IVON03                                 00390083
      FF083 = RVON05 + RVON04                                           00400083
C                                                                       00410083
      IDON01 = IVON01 + 10                                              00420083
      IDDN2A (1,1) = IVON02 + 20                                        00430083
      IDDN3A (2,3,4) = IVON03 + 40                                      00440083
C                                                                       00450083
      RETURN                                                            00460083
      END                                                               00470083

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:
This editor can edit this entry and tell us a bit about themselves by clicking the Edit icon.

20090724 13:30:52 nbsp Welcome to the Wiki Howdy Ms. or Mr. Dickey, and Welcome to the Wiki!    My names Evan, pleased to meet you!  I noticed that you removed the phrase about the Center for Geotechnical Modeling being a neat place to visit. and I was wondering why?  Once again, welcome to the wiki! wiki:gnome:Users/JabberWokky Evan JabberWokky Edwards

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


    Program ztrsyl_example

!     ZTRSYL Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: ztrsyl
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: scale
      Integer :: i, ifail, info, lda, ldb, ldc, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), c(:, :)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZTRSYL Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldb = n
      ldc = m
      Allocate (a(lda,m), b(ldb,n), c(ldc,n))

!     Read A, B and C from data file

      Read (nin, *)(a(i,1:m), i=1, m)
      Read (nin, *)(b(i,1:n), i=1, n)
      Read (nin, *)(c(i,1:n), i=1, m)

!     Solve the Sylvester equation A*X + X*B = C for X
      Call ztrsyl('No transpose', 'No transpose', 1, m, n, a, lda, b, ldb, c, &
        ldc, scale, info)
      If (info>=1) Then
        Write (nout, 100)
        Write (nout, *)
        Flush (nout)
      End If

!     Print X
!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', m, n, c, &
        ldc, 'Bracketed', 'F8.4', 'Solution Matrix', 'I', rlabs, 'I', clabs, &
        80, 0, ifail)

100   Format (/, ' A and B have common or very close eigenvalues.', /, ' Pe', &
        'rturbed values were used to solve the equations')
    End Program


text:
module oddeven

  ! Module for Capreole (2D)
  ! Author: Garrelt Mellema
  ! Date: 2004-05-12 (previous 2003-08-26)
  ! This module is also accepted by the F compiler
  !
  ! This module contains the routines related to the correction
  ! of the odd-even decoupling / carbuncle phenomenon
  !
  ! This is achieved through a local oscillation filter. The
  ! state is searched for oscillations, after which diffusion
  ! is applied.
  !
  ! This version used allocation in order to limit the use of
  ! stack memory.

  use precision
  use scaling
  use sizes
  use mesh
  use grid
  use atomic
  use geometry
  use hydro
  use times

  private

  ! Shock detection parameter
  real(kind=dp),parameter,private :: shockDetectFactor = 0.5_dp
  ! The diffusion coefficient used
  real(kind=dp),parameter,private :: eta=0.1_dp

  integer,private :: i,j,k,ieq,m
  real(kind=dp),private :: deltaPressure

  ! Counters
  integer :: nrOfXCorrections,nrOfYCorrections,nrOfZCorrections

  ! Flag for shock detection
  ! ( exported via state(neq) )
  integer,dimension(:,:,:),allocatable,save :: flag

  ! Diffusive fluxes
  real(kind=dp),dimension(:,:,:,:),allocatable,save :: fdiff
  real(kind=dp),dimension(:,:,:,:),allocatable,save :: gdiff
  real(kind=dp),dimension(:,:,:,:),allocatable,save :: hdiff

  public :: odd_even

contains
  !========================================================================

  subroutine odd_even (newold,action)

    ! This routine handles the odd-even fix interface with the
    ! integration routine. The actual work is done in the set and
    ! apply routines for the different coordinate directions.

    integer,intent(in) :: action ! what to do:
    ! 1: fix x-direction
    ! 2: fix y-direction
    ! 0: fix all directions
    ! other values: do nothing
    integer,intent(in) :: newold

    ! Point state to appropriate array
    state => set_state_pointer(newold)

    ! allocate flag and flux arrays if not allocated before
    if (.not.(allocated(flag))) then
       allocate(flag(sx-mbc:ex+mbc,sy-mbc:ey+mbc,sz-mbc:ez+mbc))
       allocate(fdiff(sx-mbc:ex+mbc,sy-mbc:ey+mbc,sz-mbc:ez+mbc,neq))
       !allocate(gdiff(sx-mbc:ex+mbc,sy-mbc:ey+mbc,sz-mbc:ez+mbc,neq))
       !allocate(hdiff(sx-mbc:ex+mbc,sy-mbc:ey+mbc,sz-mbc:ez+mbc,neq))
    endif

    ! Figure out what to do.
    select case (action)
    case (0)
       call set_odd_even_x ()
       !state(sx:ex,sy:ey,sz:ez,neq)=state(sx:ex,sy:ey,sz:ez,neq)+ &
       !     real(flag(sx:ex,sy:ey,sz:ez),dp)
       call apply_odd_even_x ()
       call set_odd_even_y ()
       !state(sx:ex,sy:ey,sz:ez,neq)=state(sx:ex,sy:ey,sz:ez,neq)+ &
       !     real(flag(sx:ex,sy:ey,sz:ez),dp)
       call apply_odd_even_y ()
       call set_odd_even_z ()
       !state(sx:ex,sy:ey,sz:ez,neq)=state(sx:ex,sy:ey,sz:ez,neq)+ &
       !     real(flag(sx:ex,sy:ey,sz:ez),dp)
       call apply_odd_even_z ()
    case (1)
       call set_odd_even_x ()
       call apply_odd_even_x ()
       !state(sx:ex,sy:ey,sz:ez,neq)=state(sx:ex,sy:ey,sz:ez,neq)+ &
       !     real(flag(sx:ex,sy:ey,sz:ez),dp)
    case (2)
       call set_odd_even_y ()
       call apply_odd_even_y ()
       !state(sx:ex,sy:ey,sz:ez,neq)=state(sx:ex,sy:ey,sz:ez,neq)+ &
       !     real(flag(sx:ex,sy:ey,sz:ez),dp)
    case (3)
       call set_odd_even_z ()
       call apply_odd_even_z ()
       !state(sx:ex,sy:ey,sz:ez,neq)=state(sx:ex,sy:ey,sz:ez,neq)+ &
       !     real(flag(sx:ex,sy:ey,sz:ez),dp)
    case default
       ! Do nothing
    end select

  end subroutine odd_even

  !---------------------------------------------------------------------------

  subroutine set_odd_even_x

    ! This routine find shocks in the perpendicular direction,
    ! then looks for density oscillations along those shocks,
    ! and calculates a diffusive flux if found.

    integer :: nrOfFlags,cellCount
    integer :: imin,iplus

    ! Reset flags
    flag(:,:,:) = 0
    cellCount=0
    nrOfXCorrections=0

    ! Reset diffusive flux
    fdiff(:,:,:,:)=0.0d0

    ! Find the shocks in y and z direction, set flag to 1.
    nrOfFlags=detect_shock_y (1)
    nrOfFlags=detect_shock_z (1)

    ! Test for odd-even pattern.
    ! Use 4-point up and down pattern for this
    ! Only for flagged cells with shock in y/z-direction.
    ! Set flag to 2 in those zones.
    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             cellCount = 0
             do m=-2,1
                if (flag(i+m,j,k) == 1 .or. flag(i+m,j,k) == 2)  &
                     cellCount = cellCount + 1
             enddo
             if(cellCount == 4) then
                if(state(i-2,j,k,RHO) > state(i-1,j,k,RHO).and. &
                     state(i-1,j,k,RHO) < state(i,j,k  ,RHO).and. &
                     state(i,j,k  ,RHO) > state(i+1,j,k,RHO)) &
                     flag(i,j,k) = 2
                if(state(i-2,j,k,RHO) < state(i-1,j,k,RHO).and. &
                     state(i-1,j,k,RHO) > state(i,j,k,RHO).and.  &
                     state(i,j,k  ,RHO) < state(i+1,j,k,RHO)) &
                     flag(i,j,k) = 2
!               if(cellCount == 5) then
!                  if(state(i-2,j,k,RHO) > state(i-1,j,k,RHO).and. &
!                       state(i-1,j,k,RHO) < state(i,j,k  ,RHO).and. &
!                       state(i,j,k  ,RHO) > state(i+1,j,k,RHO).and. &
!                       state(i+1,j,k,RHO) < state(i+2,j,k,RHO)) &
!                       flag(i,j,k) = 2
!                  if(state(i-2,j,k,RHO) < state(i-1,j,k,RHO).and. &
!                       state(i-1,j,k,RHO) > state(i,j,k,RHO).and.  &
!                       state(i,j,k  ,RHO) < state(i+1,j,k,RHO).and.  &
!                       state(i+1,j,k,RHO) > state(i+2,j,k,RHO)) &
!                       flag(i,j,k) = 2
             endif
          enddo
       enddo
    enddo

    ! Calculate diffusive flux for the cells flagged with a 2
    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             if ( flag(i,j,k) == 2 ) then
                nrOfXCorrections = nrOfXCorrections + 1
                imin=max(i-1,1)      ! diffusive flux at grid edge is zero
                iplus=min(i+1,meshx) ! diffusive flux at grid edge is zero
                do ieq=1,neq
                   fdiff(i,j,k,ieq)=state(imin,j,k,ieq)-state(i,j,k,ieq)
                   fdiff(i+1,j,k,ieq)=state(i,j,k,ieq)-state(iplus,j,k,ieq)
                end do
             end if
          end do
       end do
    end do

  end subroutine set_odd_even_x

!------------------------------------------------------------------------------

  subroutine apply_odd_even_x

    ! Apply the diffusive flux

    if (nrOfXCorrections > 0) then
       do ieq=1,neq
          do k=sz,ez
             do j=sy,ey
                do i=sx,ex
                   state(i,j,k,ieq)=state(i,j,k,ieq)+eta* &
                        (fdiff(i,j,k,ieq)-fdiff(i+1,j,k,ieq))
                enddo
             enddo
          enddo
       enddo

    end if

  end subroutine apply_odd_even_x

  !--------------------------------------------------------------------------

  subroutine set_odd_even_y

    ! This routine find shocks in the perpendicular direction,
    ! then looks for density oscillations along those shocks,
    ! and calculates a diffusive flux if found.

    integer :: nrOfFlags,cellCount
    integer :: jmin,jplus

    ! Reset flags
    flag(:,:,:) = 0
    cellCount=0
    nrOfYCorrections=0

    ! Reset diffusive flux
    fdiff(:,:,:,:)=0.0d0

    ! Find the shocks in x and z direction, set flag to 3
    nrOfFlags=detect_shock_x (3)
    nrOfFlags=detect_shock_z (3)

    ! Test for odd-even pattern in the y-direction.
    ! Use 4-point up and down pattern for this
    ! Only for flagged cells with shock in x/z-direction.
    ! Set flag to 4 in those zones.
    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             cellCount = 0
             do m=-2,1
                if (flag(i,j+m,k) == 3 .or. flag(i,j+m,k) == 4) &
                     cellCount = cellCount + 1
             enddo
             if(cellCount == 4) then
                if(state(i,j-2,k,RHO) > state(i,j-1,k,RHO).and. &
                     state(i,j-1,k,RHO) < state(i,j,k  ,RHO).and. &
                     state(i,j,k  ,RHO) > state(i,j+1,k,RHO)) &
                     flag(i,j,k) = 4
                if(state(i,j-2,k,RHO) < state(i,j-1,k,RHO).and. &
                     state(i,j-1,k,RHO) > state(i,j,k,RHO).and.  &
                     state(i,j,k  ,RHO) < state(i,j+1,k,RHO)) &
                     flag(i,j,k) = 4
             endif
!                  if(state(i,j-1,k,RHO) < state(i,j,k  ,RHO).and. &
!                       state(i,j,k  ,RHO) > state(i,j+1,k,RHO).and. &
!                       state(i,j+1,k,RHO) < state(i,j+2,k,RHO)) &
!                       flag(i,j,k) = 4
!                  if(state(i,j-1,k,RHO) > state(i,j,k,RHO).and.  &
!                       state(i,j,k  ,RHO) < state(i,j+1,k,RHO).and.  &
!                       state(i,j+1,k,RHO) > state(i,j+2,k,RHO)) &
!                       flag(i,j,k) = 4

!               if(cellCount == 5) then
!                  if(state(i,j-2,k,RHO) > state(i,j-1,k,RHO).and. &
!                       state(i,j-1,k,RHO) < state(i,j,k  ,RHO).and. &
!                       state(i,j,k  ,RHO) > state(i,j+1,k,RHO).and. &
!                       state(i,j+1,k,RHO) < state(i,j+2,k,RHO)) &
!                       flag(i,j,k) = 4
!                  if(state(i,j-2,k,RHO) < state(i,j-1,k,RHO).and. &
!                       state(i,j-1,k,RHO) > state(i,j,k,RHO).and.  &
!                       state(i,j,k  ,RHO) < state(i,j+1,k,RHO).and. &
!                       state(i,j+1,k,RHO) > state(i,j+2,k,RHO)) &
!                       flag(i,j,k) = 4
!               endif

          enddo
       enddo
    enddo

    ! Calculate diffusive flux for the cells flagged with a 4
    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             if (flag(i,j,k) == 4) then
                nrOfYCorrections = nrOfYCorrections + 1
                jmin=max(j-1,1)      ! diffusive flux at grid edge is zero
                jplus=min(j+1,meshy) ! diffusive flux at grid edge is zero
                do ieq=1,neq
                   fdiff(i,j,k,ieq)=state(i,jmin,k,ieq)-state(i,j,k,ieq)
                   fdiff(i,j+1,k,ieq)=state(i,j,k,ieq)-state(i,jplus,k,ieq)
                end do
             end if
          end do
       end do
    end do

  end subroutine set_odd_even_y

  !--------------------------------------------------------------------------

  subroutine apply_odd_even_y ()

    ! Apply the diffusive flux

    if (nrOfYCorrections > 0) then
       do ieq=1,neq
          do k=sz,ez
             do j=sy,ey
                do i=sx,ex
                   state(i,j,k,ieq)=state(i,j,k,ieq)+eta* &
                        (fdiff(i,j,k,ieq)-fdiff(i,j+1,k,ieq))
                enddo
             enddo
          enddo
       enddo

    end if

  end subroutine apply_odd_even_y

  !--------------------------------------------------------------------------

  subroutine set_odd_even_z

    ! This routine find shocks in the perpendicular direction,
    ! then looks for density oscillations along those shocks,
    ! and calculates a diffusive flux if found.

    integer :: nrOfFlags,cellCount
    integer :: kmin,kplus

    ! Reset flags
    flag(:,:,:) = 0
    cellCount=0
    nrOfZCorrections=0

    ! Reset diffusive flux
    fdiff(:,:,:,:)=0.0d0

    ! Find the shocks in x and y direction, set flag to 5
    nrOfFlags=detect_shock_x (5)
    nrOfFlags=detect_shock_y (5)

    ! Test for odd-even pattern.
    ! Use 4-point up and down pattern for this
    ! Check only for flagged cells with shock in x/y-direction.
    ! Set flag to 6 in those zones.
    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             cellCount = 0
             do m=-2,1
                if (flag(i,j,k+m) == 5 .or. flag(i,j,k+m) == 6) &
                     cellCount = cellCount + 1
             enddo
             if(cellCount == 4) then
                if(state(i,j,k-2,RHO) > state(i,j,k-1,RHO).and. &
                     state(i,j,k-1,RHO) < state(i,j,k  ,RHO).and. &
                     state(i,j,k  ,RHO) > state(i,j,k+1,RHO)) &
                     flag(i,j,k) = 6
                if(state(i,j,k-2,RHO) < state(i,j,k-1,RHO).and. &
                     state(i,j,k-1,RHO) > state(i,j,k,RHO).and.  &
                     state(i,j,k  ,RHO) < state(i,j,k+1,RHO)) &
                     flag(i,j,k) = 6
             endif

!                  if(state(i,j,k-1,RHO) < state(i,j,k  ,RHO).and. &
!                       state(i,j,k  ,RHO) > state(i,j,k+1,RHO).and. &
!                       state(i,j,k+1,RHO) < state(i,j,k+2,RHO)) &
!                       flag(i,j,k) = 6
!                  if(state(i,j,k-1,RHO) > state(i,j,k,RHO).and.  &
!                       state(i,j,k  ,RHO) < state(i,j,k+1,RHO).and.  &
!                       state(i,j,k+1,RHO) > state(i,j,k+2,RHO)) &
!                       flag(i,j,k) = 6

!               if(cellCount == 5) then
!                  if(state(i,j,k-2,RHO) > state(i,j,k-1,RHO).and. &
!                       state(i,j,k-1,RHO) < state(i,j,k  ,RHO).and. &
!                       state(i,j,k  ,RHO) > state(i,j,k+1,RHO).and. &
!                       state(i,j,k+1,RHO) < state(i,j,k+2,RHO)) &
!                       flag(i,j,k) = 6
!                  if(state(i,j,k-2,RHO) < state(i,j,k-1,RHO).and. &
!                       state(i,j,k-1,RHO) > state(i,j,k,RHO).and.  &
!                       state(i,j,k  ,RHO) < state(i,j,k+1,RHO).and. &
!                       state(i,j,k+1,RHO) > state(i,j,k+2,RHO)) &
!                       flag(i,j,k) = 6
!               endif

          enddo
       enddo
    enddo

    ! Calculate diffusive flux for the cells flagged with a 6
    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             if (flag(i,j,k) == 6) then
                nrOfZCorrections = nrOfZCorrections + 1
                kmin=max(k-1,1)      ! diffusive flux at grid edge is zero
                kplus=min(k+1,meshz) ! diffusive flux at grid edge is zero
                do ieq=1,neq
                   fdiff(i,j,k,ieq)=state(i,j,kmin,ieq)-state(i,j,k,ieq)
                   fdiff(i,j,k+1,ieq)=state(i,j,k,ieq)-state(i,j,kplus,ieq)
                end do
             end if
          end do
       end do
    end do

  end subroutine set_odd_even_z

  !--------------------------------------------------------------------------

  subroutine apply_odd_even_z ()

    ! Apply the diffusive flux

    if (nrOfZCorrections > 0) then
       do ieq=1,neq
          do k=sz,ez
             do j=sy,ey
                do i=sx,ex
                   state(i,j,k,ieq)=state(i,j,k,ieq)+eta* &
                        (fdiff(i,j,k,ieq)-fdiff(i,j,k+1,ieq))
                enddo
             enddo
          enddo
       enddo

    end if

  end subroutine apply_odd_even_z

  !--------------------------------------------------------------------------

  function detect_shock_x (marker)

    ! Detect shocks in the x-direction and flag cells with marker
    ! This is done by looking at the pressure jumps.

    ! Output: number of cells flagged

    integer :: detect_shock_x

    integer,intent(in) :: marker

    detect_shock_x=0

    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             deltaPressure = (pressr(i+1,j,k)-pressr(i,j,k)) / &
                  max(pressr(i+1,j,k),pressr(i,j,k))
             if(-(deltaPressure) > shockDetectFactor) then
                flag(i-4,j,k) = marker
                flag(i-3,j,k) = marker
                flag(i-2,j,k) = marker
                flag(i-1,j,k) = marker
                flag(i  ,j,k) = marker
                detect_shock_x = detect_shock_x + 5
             endif
             if((deltaPressure) > shockDetectFactor) then
                flag(i+5,j,k) = marker
                flag(i+4,j,k) = marker
                flag(i+3,j,k) = marker
                flag(i+2,j,k) = marker
                flag(i+1,j,k) = marker
                detect_shock_x = detect_shock_x + 5
             endif
          enddo
       enddo
    enddo

  end function detect_shock_x

  !--------------------------------------------------------------------------

  function detect_shock_y (marker)

    ! Detect shocks in y-direction and flag cells with marker

    ! Output: number of cells flagged

    integer :: detect_shock_y

    integer,intent(in) :: marker

    detect_shock_y=0
    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             deltaPressure = (pressr(i,j+1,k)-pressr(i,j,k)) / &
                  max(pressr(i,j+1,k),pressr(i,j,k))
             if(-(deltaPressure) > shockDetectFactor) then
                flag(i,j-4,k) = marker
                flag(i,j-3,k) = marker
                flag(i,j-2,k) = marker
                flag(i,j-1,k) = marker
                flag(i  ,j,k) = marker
                detect_shock_y = detect_shock_y + 5
             endif
             if((deltaPressure) > shockDetectFactor) then
                flag(i,j+5,k) = marker
                flag(i,j+4,k) = marker
                flag(i,j+3,k) = marker
                flag(i,j+2,k) = marker
                flag(i,j+1,k) = marker
                detect_shock_y = detect_shock_y + 5
             endif
          enddo
       enddo
    enddo

  end function detect_shock_y

  !--------------------------------------------------------------------------

  function detect_shock_z (marker)

    ! detect shocks in the z-direction and flag cells with marker

    ! Output: number of cells flagged

    integer :: detect_shock_z

    integer,intent(in) :: marker

    detect_shock_z=0
    do k=sz,ez
       do j=sy,ey
          do i=sx,ex
             deltaPressure = (pressr(i,j,k+1)-pressr(i,j,k)) / &
                  max(pressr(i,j,k+1),pressr(i,j,k))
             if(-(deltaPressure) > shockDetectFactor) then
                flag(i,j,k-4) = marker
                flag(i,j,k-3) = marker
                flag(i,j,k-2) = marker
                flag(i,j,k-1) = marker
                flag(i  ,j,k) = marker
                detect_shock_z = detect_shock_z + 5
             endif
             if((deltaPressure) > shockDetectFactor) then
                flag(i,j,k+5) = marker
                flag(i,j,k+4) = marker
                flag(i,j,k+3) = marker
                flag(i,j,k+2) = marker
                flag(i,j,k+1) = marker
                detect_shock_z = detect_shock_z + 5
             endif
          enddo
       enddo
    enddo

  end function detect_shock_z

end module oddeven

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse


text:
! Program to test conversion.  Does not actualy test the generated code
program convert
   implicit none
   integer(kind=4) i
   integer(kind=8) m
   real(kind=4) r
   real(kind=8) q
   complex(kind=4) c
   complex(kind=8) z

   ! each of these should generate a single intrinsic conversion expression
   i = int(i)
   i = int(m)
   i = int(r)
   i = int(q)
   i = int(c)
   i = int(z)
   m = int(i, kind=8)
   m = int(m, kind=8)
   m = int(r, kind=8)
   m = int(q, kind=8)
   m = int(c, kind=8)
   m = int(z, kind=8)
   r = real(i)
   r = real(m)
   r = real(r)
   r = real(q)
   r = real(c)
   r = real(z, kind=4)
   q = real(i, kind=8)
   q = real(m, kind=8)
   q = real(r, kind=8)
   q = real(q, kind=8)
   q = real(c, kind=8)
   ! Note real(<complex>) returns the type kind of the argument.
   q = real(z)
end program

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      DOUBLE PRECISION FUNCTION READA(A,ISTART)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*1 A(80)
      NINE=ICHAR('9')
      IZERO=ICHAR('0')
      MINUS=ICHAR('-')
      IDOT=ICHAR('.')
      IDIG=0
      C1=0
      C2=0
      ONE=1.D0
      X = 1.D0
      DO 10 J=ISTART,80
         N=ICHAR(A(J))
         IF(N.LE.NINE.AND.N.GE.IZERO .OR. N.EQ.MINUS.OR.N.EQ.IDOT)GOTO 2
     10
   10 CONTINUE
      READA=0.D0
      RETURN
   20 CONTINUE
      DO 30 I=J,80
         N=ICHAR(A(I))
         IF(N.LE.NINE.AND.N.GE.IZERO) THEN
            IDIG=IDIG+1
            IF (IDIG.GT.10) GOTO 60
            C1=C1*10+N-IZERO
         ELSEIF(N.EQ.MINUS.AND.I.EQ.J) THEN
            ONE=-1.D0
         ELSEIF(N.EQ.IDOT) THEN
            GOTO 40
         ELSE
            GOTO 60
         ENDIF
   30 CONTINUE
   40 CONTINUE
      IDIG=0
      DO 50 II=I+1,80
         N=ICHAR(A(II))
         IF(N.LE.NINE.AND.N.GE.IZERO) THEN
            IDIG=IDIG+1
            IF (IDIG.GT.10) GOTO 60
            C2=C2*10+N-IZERO
            X = X /10
         ELSEIF(N.EQ.MINUS.AND.II.EQ.I) THEN
            X=-X
         ELSE
            GOTO 60
         ENDIF
   50 CONTINUE
C
C PUT THE PIECES TOGETHER
C
   60 CONTINUE
      READA= ONE * ( C1 + C2 * X)
      RETURN
      END

ext: for

max_stars_repo_name: openmopac/MOPAC-archive

max_issues_repo_name: openmopac/MOPAC-archive

max_forks_repo_name: openmopac/MOPAC-archive


text:
MODULE params_model

USE common, ONLY: r_size

IMPLICIT NONE

PUBLIC

!-----------------------------------------------------------------------
! General parameters
!-----------------------------------------------------------------------

  ! Now definable via namelist at runtime:

  ! MOM4 ncep2012 tripolar converted to spherical
#ifdef DYNAMIC
  INTEGER :: nlon=602
  INTEGER :: nlat=736
  INTEGER :: nlev=30
#else
  INTEGER,PARAMETER :: nlon=602 ! xi_rho
  INTEGER,PARAMETER :: nlat=736 ! eta_rho
  INTEGER,PARAMETER :: nlev=30
#endif

  INTEGER,PARAMETER :: ilev_sfc=1
!
  INTEGER,PARAMETER :: nv3d=4 ! u,v,t,s
  INTEGER,PARAMETER :: nv2d=4 ! z,ubar,vbar,Hsbl
  INTEGER,PARAMETER :: nv4d=0 ! x,y,z                !(OCEAN) STEVE: add t,x,y,z,id for DRIFTERS
  ! 3d
  INTEGER,PARAMETER :: iv3d_u=1
  INTEGER,PARAMETER :: iv3d_v=2
  INTEGER,PARAMETER :: iv3d_t=3
  INTEGER,PARAMETER :: iv3d_s=4
  ! 2d
  INTEGER,PARAMETER :: iv2d_z=1
  INTEGER,PARAMETER :: iv2d_ubar=2
  INTEGER,PARAMETER :: iv2d_vbar=3
  INTEGER,PARAMETER :: iv2d_hbl=4

  INTEGER,PARAMETER :: iv2d_ssh=5              !(OCEAN) ! time averaged thickness of top model grid cell (m) plus patm/(grav*rho0)
  INTEGER,PARAMETER :: iv2d_sst=6              !(OCEAN) ! time averaged sst (Kelvin) passed to atmosphere/ice model
  INTEGER,PARAMETER :: iv2d_sss=7              !(OCEAN) ! time averaged sss (psu) passed to atmosphere/ice models
  INTEGER,PARAMETER :: iv2d_eta=8              !(OCEAN) ! eta sea surface perturbation from mom4's ocean_barotropic.res.nc restart file
  INTEGER,PARAMETER :: iv2d_mld=9              !(OCEAN) ! mixed layer depth
  INTEGER,PARAMETER :: iv4d_x=1                !(OCEAN) (DRIFTERS)
  INTEGER,PARAMETER :: iv4d_y=2                !(OCEAN) (DRIFTERS)
  INTEGER,PARAMETER :: iv4d_z=3                !(OCEAN) (DRIFTERS)

  ! Initialize via subroutine below:
  INTEGER,SAVE :: nij0           ! Number of gridpoints handled by myrank processor
  INTEGER,SAVE :: nlevall        ! Total number of variables and levels (3d + 2d)
  INTEGER,SAVE :: ngpv           ! Total number of gridpoints, including nij0*nlevall

  !
  ! Elements
  !
  CHARACTER(4) :: element(nv3d+nv2d+nv4d)
  !
  ! Elements
  !
! element(iv3d_u) = 'U   '
! element(iv3d_v) = 'V   '
! element(iv3d_t) = 'T   '
! element(iv3d_s) = 'S   '
! element(nv3d+iv2d_z) = 'ZETA'
! element(nv3d+iv2d_ubar) = 'UBAR'
! element(nv3d+iv2d_vbar) = 'VBAR'
! element(nv3d+iv2d_hbl) = 'HBL '

! element(nv3d+iv2d_ssh) = 'SSH '        !(OCEAN)
! element(nv3d+iv2d_sst) = 'SST '        !(OCEAN)
! element(nv3d+iv2d_sss) = 'SSS '        !(OCEAN)
! if (DO_ALTIMETRY) then
!   element(nv3d+iv2d_eta) = 'eta '      !(OCEAN)
! endif
! if (DO_MLD) then
!   element(nv3d+iv2d_mld) = 'mld'       !(OCEAN)
! endif
! if (DO_DRIFTERS) then
!   element(nv3d+nv2d+iv4d_x) = 'X   '             !(OCEAN) (DRIFTERS)
!   element(nv3d+nv2d+iv4d_y) = 'Y   '             !(OCEAN) (DRIFTERS)
!   element(nv3d+nv2d+iv4d_z) = 'Z   '             !(OCEAN) (DRIFTERS)
! endif

  CHARACTER(14) :: SSHclm_file = 'aEtaCds9399.nc'
  CHARACTER(32) :: ts_basefile = 'ocean_temp_salt.res.nc'
  CHARACTER(32) :: uv_basefile = 'ocean_velocity.res.nc'
  CHARACTER(32) :: sf_basefile = 'ocean_sbc.res.nc'
  CHARACTER(32) :: sh_basefile = 'ocean_barotropic.res.nc'
  CHARACTER(32) :: hs_basefile = 'ocean_TS.nc'

  ! For grid_spec.nc data file:
  CHARACTER(12) :: gridfile = 'grd.nc'

  ! Bounds checking (for output by common_mom4.f90::write_restart)
  LOGICAL :: do_physlimit=.true.
  REAL(r_size) :: max_t = 40.0d0 ! ºC
  REAL(r_size) :: min_t = -4.0d0 ! ºC
  REAL(r_size) :: max_s = 50.0d0 ! psu
  REAL(r_size) :: min_s =  0.0d0 ! psu

!-----------------------------------------------------------------------
!LPP has added
!Constants - Limits for oceanic variables to be assimilated by ROMS
!-----------------------------------------------------------------------
   REAL,PARAMETER :: Tmin= -2.5
   REAL,PARAMETER :: Tmax= 40.0
   REAL,PARAMETER :: Smax= 42.0
   REAL,PARAMETER :: Smin= 30.0
   REAL,PARAMETER :: Umax= 2.5
   REAL,PARAMETER :: Vmax= 2.5
   REAL,PARAMETER :: ssh_min=-3.5
   REAL,PARAMETER :: ssh_max= 3.5

  LOGICAL,SAVE :: params_model_initialized = .false.

CONTAINS

SUBROUTINE initialize_params_model

  IMPLICIT NONE

  if (params_model_initialized) then
    WRITE(6,*) "initialize_params_model:: already initialized, RETURNING..."
    RETURN
  endif

  nij0=nlon*nlat
  nlevall=nlev*nv3d+nv2d
  ngpv=nij0*nlevall

  params_model_initialized = .true.

END SUBROUTINE initialize_params_model

END MODULE params_model

max_stars_repo_name: GEOS-ESM/Ocean-LETKF

max_issues_repo_name: GEOS-ESM/Ocean-LETKF

max_forks_repo_name: GEOS-ESM/Ocean-LETKF


text:
C
C***********************************************************************
C                                                                      *
C            NACHOS II - A Finite Element Computer Program             *
C                        for Incompressible Flow Problems              *
C                                                                      *
C     Copyright (c) 1986,2019   National Technology & Engineering      *
C                               Solutions of Sandia, LLC (NTESS)       *
C                                                                      *
C                            All rights reserved.                      *
C                                                                      *
C     This software is distributed under the BSD 3-Clause License.     *
C                                                                      *
C***********************************************************************
C
      SUBROUTINE INVRT3 (A,DET)
C
C     ******************************************************************
C
C     SUBROUTINE TO INVERT A 3X3 MATRIX
C     INVERSE IS RETURNED IN THE ORIGINAL MATRIX
C
C     ******************************************************************
C
      DIMENSION A(3,3)
C
C     ******************************************************************
C
      F11=A(2,2)*A(3,3)-A(2,3)*A(3,2)
      F21=A(1,2)*A(3,3)-A(3,2)*A(1,3)
      F31=A(2,3)*A(1,2)-A(1,3)*A(2,2)
C
      F12=A(2,1)*A(3,3)-A(3,1)*A(2,3)
      F22=A(1,1)*A(3,3)-A(1,3)*A(3,1)
      F32=A(1,1)*A(2,3)-A(2,1)*A(1,3)
C
      F13=A(2,1)*A(3,2)-A(3,1)*A(2,2)
      F23=A(1,1)*A(3,2)-A(3,1)*A(1,2)
      F33=A(1,1)*A(2,2)-A(1,2)*A(2,1)
C
      DET=A(1,1)*F11-A(1,2)*F12+A(1,3)*F13
      IF (DET.EQ.0.0) RETURN
C
      A(1,1)=F11/DET
      A(2,1)=-F12/DET
      A(3,1)=F13/DET
      A(1,2)=-F21/DET
      A(2,2)=F22/DET
      A(3,2)=-F23/DET
      A(1,3)=F31/DET
      A(2,3)=-F32/DET
      A(3,3)=F33/DET
C
      RETURN
      END

max_stars_repo_name: nachos-ii/nachos-ii

max_issues_repo_name: nachos-ii/nachos-ii

max_forks_repo_name: nachos-ii/nachos-ii


text:
Hi!  Im Jaymes.
I have the Aisu Pop popsicle stand at the Farmers Market (feel free to come by and say hi, even if you dont want a pop).
Ive lived in Davis since 2002.  I consider Orlando, FL my hometown and Baton Rouge, LA is where I had an amazing childhood.
I love the Davis Wiki and figured its about time I did some contributing too.  So heres my start!

20080129 23:45:55 nbsp Jaymes! How are you?  Users/ElleWeber

20080131 22:23:52 nbsp Jaymes makes more than popsicles, although Aisu Pop is locally famous for good reason. I expect shell let the Wiki world know when shes got another public gig, and if you ever have a chance to eat other foods shes made, I recommend you take it! Users/DougWalter

20080317 21:19:54 nbsp hey! my email is MailTo(weber.elizabeth AT gmail DOT com) Users/ElleWeber

20080317 22:02:10 nbsp although i havent tried the Popsicles yet, I once walked home from school and had a cup of your wonderful soup, which had a subtle lemon grass flavor and various mushrooms and basil, it was excellent. Its starting to get hot, so that should mean i will frequenting the popsicles soon. Users/MattHh

20080325 19:25:11 nbsp ooh lime is like one of my favorite flavors, so the kafir lime is definetly going to be my first try. Perhaps next wednesday when school starts :). Users/MattHh

20080711 13:51:46 nbsp Check out the 60s Jan & Dean song Popsicle TruckUsers/GarySaylin

20080717 18:04:59 nbsp WHOO!!! I love popsicles! Users/EricWilliamWong

20080726 16:38:01 nbsp Also, check out the Murmaids 1964 song Popsicles and Icicleshttp://www.youtube.com/watch?v1y3lt2segrE Users/GarySaylin

20080901 21:00:48 nbsp Okay, of course, we all love Jaymess popsicles and breakfast sandwiches at Farmers Market.  However, this weekend Kara and I were delighted to have her cater a brunch for 40 people at our house.  And, everything was marvelous and an absolute joy to us, and our friends and family from around the country that joined us.  Thank you Jaymes! Users/ScottLay

20090511 15:26:40 nbsp I LOVE your Farmers Market sandwiches. LOVE them. Could I interview you for my blog about sandwiches some time? Users/ifoundthistape

20100120 16:58:58 nbsp Hi
I saw the article featuring you in the Sac News & Review today. Sounds like good work that you are doing in Davis. Although, I havent been over that way to try a pop or sandwich as of yet, it comes highly recommended. It was a funny thing this past Thanksgiving when I drove down two passengers (1 UCDavis student & 1 S.F. Bay traveler (off of Craigslist))to L.A.and a big part of our conversation was of a woman named Jaymes with the yummy popsicles. Just wanted to let you know that you have a very good reputation going.

All the Best

Lisa
Now in Sac Users/rumor

20101201 21:13:22 nbsp will you marry me?? Users/Hyungmi


text:
      SUBROUTINE FFHELP (*,*,J)
      CHARACTER*1     QMARK
      CHARACTER*4     STOP,     YES,      HELP,     XX
      COMMON /MACHIN/ MACH
      COMMON /SYSTEM/ DUMMY(3), IN
      COMMON /XREADX/ NOUT
      COMMON /XECHOX/ SKIP(2),  IECHOS
      COMMON /QMARKQ/ QMARK
      DATA    STOP,   YES,      HELP  /   'STOP',   'Y   ',   'HELP' /
C
C     THIS ROUTINE IS CALLED ONLY BY FF
C
      GO TO (10,50,100,120,140), J
 10   WRITE (NOUT,20)
 20   FORMAT (///1X,
     1  'GENERATED OUTPUT CARDS ARE SAVED ONLY IF FILE NAME IS GIVEN.',
     2  //,' YOU MAY ENTER NASTRAN EXECUTIVE CONTROL AND CASE CONTROL',
     2  ' CARDS FIRST',/,' (NO INPUT ECHO ON SCREEN)', //,
     3  ' ADDITIONAL INPUT INFORMATION WILL BE GIVEN WHEN YOU ENTER ',
     3  12H'BEGIN BULK', //,
     4  ' YOU MAY QUIT FREE-FIELD PROGRAM AT ANY TIME BY ENTERING ',
     4  6H'STOP', /,' NORMALLY, JOB TERMINATES BY ',9H'ENDDATA', //,
     5  ' YOU MAY USE ',10H'READFILE',' COMMAND TO READ ANY FILE WHICH',
     5  14H WAS 'STOPPED', /,
     5  ' BEFORE, AND CONTINUE FROM WHERE THE PREVIOUS JOB ENDED', //,
     6  ' FREE-FIELD INPUT IS AVAILABLE ONLY IN BULK DATA SECTION', /,
     6  ' AND IS ACTIVATED BY A COMMA OR EQUAL SIGN IN COLS. 1 THRU 10',
     7  //,' BOTH UPPER-CASE AND LOWER-CASE LETTERS ARE ACCEPTABLE',//,
     8  ' REFERENCE - G.CHAN: ',1H','COSMIC/NASTRAN FREE-FIELD INPUT',
     8  2H',, /13X,'12TH NASTRAN USERS',1H',' COLLOQUIUM, MAY 1984')
      WRITE (NOUT,30) QMARK
 30   FORMAT (/,' MORE',A1,' (Y,N) - ')
      READ (IN,40,END=80) XX
 40   FORMAT (A4)
      CALL UPCASE (XX,4)
      IF (XX .NE. YES) GO TO 80
C
 50   WRITE (NOUT,60)
 60   FORMAT (///,' THE FOLLOWING SYMBOLS ARE USED FOR FREE-FIELD INPUT'
     1, //10X,'SYMBOL', 12X,'FUNCTION',/,9X,2('----'),5X,10('----'),
     2   /10X,', OR BLANK  FIELD SEPERATORS',
     3   /10X,'  =         DUPLICATES ONE CORRESPONDING FIELD',
     4   /10X,'  ==        DUPLICATES THE REMAINING FIELDS',
     5   /10X,'  *(N)      INCREMENT BY N',
     6   /10X,'  %(E)      ENDING VALUE BY E',
     7   /10X,'  /         THIS INPUT FIELD IS SAME AS PREVIOUS FIELD',
     8   /10X,'  J)        FIELD INDEX, J-TH FIELD (MUST FOLLOWED BY A V
     9ALUE)',
     O   /10X,')+ OR 10)   INDEX FOR CONTINUATION FIELD',
     A   /10X,'  )         (IN COL. 1 ONLY) DUPLICATES THE CONTINUATION
     BID',/22X,'OF PREVIOUS CARD INTO FIELD 1 OF CURRENT CARD',
     C   /10X,'  ,         COL.1 ONLY, AUTO-CONTINUATION ID GENERATION',
     D   /10X,'  =(N)      1ST FIELD ONLY, DUPLICATES N CARDS WITH PROPE
     ER',/22X,' INCREMENTS',
     F   /12X,'+A-I',6X,'CONTINUATION ID CAN BE DUPLICATED AUTOMATICALLY
     G', /22X,'ONLY IF IT IS IN PLUS-ALPHA-MINUS-INTEGER FORM',
     H  //1X,'EXAMPLES:',  /1X,'GRID, 101,,  0.  0. ,  7. 8)2  )+ABC-2',
     I   /1X,'=(11),*(1)  ,,  *(1.), /  %(23.45),==')
      IF (J.EQ.1 .OR. IECHOS.NE.-2) GO TO 170
      WRITE (NOUT,30) QMARK
      READ (IN,40,END=80) XX
      CALL UPCASE (XX,4)
      IF (XX .EQ. YES) GO TO 140
 80   IF (XX .EQ. STOP) RETURN 2
      IF (MACH.EQ.4 .AND. IN.EQ.5) REWIND IN
      GO TO 190
C
 100  WRITE (NOUT,110)
 110  FORMAT (//,24H ENTER 'N' FOR NO PUNCH,, /7X,
     1       38H'Y' FOR PUNCH IN FREE-FIELD FORMAT, OR, /7X,
     2       43H'X' FOR PUNCH IN NASTRAN FIXED-FIELD FORMAT,/)
      GO TO 190
C
 120  WRITE (NOUT,130)
 130  FORMAT (/,' MIFYLE - IS A RESERVED WORD.  TRY ANY OTHER NAME')
      GO TO 190
C
 140  WRITE (NOUT,150)
 150  FORMAT (//,' *** FREE-FIELD INPUT IS OPTIONAL.',//5X,'FOUR (4)',
     1 ' CONTROL OPTIONS ARE AVAILABLE - CAN BE ENTERED AT ANY TIME',
     2 /7X,'1.  PROMPT=ON, PROMPT=OFF, OR PROMPT=YES(DEFAULT)',
     3 /7X,'2.  SCALE/10,  OR SCALE/8',
     4 /7X,'3.  CANCEL=N,  (TO CANCEL N PREVIOUSLY GENERATED CARDS)',
     5 /7X,'4.  LIST  =N,  (TO   LIST N PREVIOUSLY GENERATED CARDS)',
     6//7X,'ENTER ''HELP'' IF YOU NEED ADDITIONAL INSTRUCTIONS',
     7//7X,'INTEGER INPUT SHOULD BE LIMITED TO 8 DIGITS',
     8 /7X,'UP TO 12 DIGITS ARE ALLOWED FOR FLOATING PT. NUMBER INPUT',
     9 /7X,'HOWEVER, ONLY UP TO 8 DIGIT ACCURACY IS KEPT',
     O /7X,'             INPUT           RESULT ',
     1 /7X,'         ------------       --------',
     2 /7X,'E.G.     123.456789         123.4567',
     3 /7X,'         123.456789+6       .12345+9',
     4 /7X,'         -123.4567D+5       -.1234+8',
     5 /7X,'         123.45678E+4       1234567.',
     6 /7X,'         0.00123456-3       .12345-5',
     7 /7X,'         0.0123456789       .0123456',
     8 /7X,'         .00000123456       .12345-5')
      IF (IECHOS .NE. -2) WRITE (NOUT,160)
 160  FORMAT (/7X,'(3 AND 4 ARE AVAILABLE ONLY IN THE FREE-FIELD STAND',
     1     '-ALONE VERSION)')
 170  WRITE (NOUT,180)
 180  FORMAT (/4X,'UP TO 94 CHARATERS ALLOWABLE ON AN INPUT LINE. ',
     1       ' C/R TO CONTINUE')
      READ (IN,40,END=80) XX
      CALL UPCASE (XX,4)
      IF (XX .EQ. HELP) GO TO 50
      IF (J .NE. 1) GO TO 80
 190  RETURN 1
      END