*DECK DQNG
      SUBROUTINE DQNG (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL,
     +   IER)
C***BEGIN PROLOGUE  DQNG
C***PURPOSE  The routine calculates an approximation result to a
C            given definite integral I = integral of F over (A,B),
C            hopefully satisfying following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A1A1
C***TYPE      DOUBLE PRECISION (QNG-S, DQNG-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, GAUSS-KRONROD(PATTERSON) RULES,
C             NONADAPTIVE, QUADPACK, QUADRATURE, SMOOTH INTEGRAND
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C NON-ADAPTIVE INTEGRATION
C STANDARD FORTRAN SUBROUTINE
C DOUBLE PRECISION VERSION
C
C           F      - Double precision
C                    Function subprogram defining the integrand function
C                    F(X). The actual name for F needs to be declared
C                    E X T E R N A L in the driver program.
C
C           A      - Double precision
C                    Lower limit of integration
C
C           B      - Double precision
C                    Upper limit of integration
C
C           EPSABS - Double precision
C                    Absolute accuracy requested
C           EPSREL - Double precision
C                    Relative accuracy requested
C                    If  EPSABS.LE.0
C                    And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                    The routine will end with IER = 6.
C
C         ON RETURN
C           RESULT - Double precision
C                    Approximation to the integral I
C                    Result is obtained by applying the 21-POINT
C                    GAUSS-KRONROD RULE (RES21) obtained by optimal
C                    addition of abscissae to the 10-POINT GAUSS RULE
C                    (RES10), or by applying the 43-POINT RULE (RES43)
C                    obtained by optimal addition of abscissae to the
C                    21-POINT GAUSS-KRONROD RULE, or by applying the
C                    87-POINT RULE (RES87) obtained by optimal addition
C                    of abscissae to the 43-POINT RULE.
C
C           ABSERR - Double precision
C                    Estimate of the modulus of the absolute error,
C                    which should EQUAL or EXCEED ABS(I-RESULT)
C
C           NEVAL  - Integer
C                    Number of integrand evaluations
C
C           IER    - IER = 0 normal and reliable termination of the
C                            routine. It is assumed that the requested
C                            accuracy has been achieved.
C                    IER.GT.0 Abnormal termination of the routine. It is
C                            assumed that the requested accuracy has
C                            not been achieved.
C           ERROR MESSAGES
C                    IER = 1 The maximum number of steps has been
C                            executed. The integral is probably too
C                            difficult to be calculated by DQNG.
C                        = 6 The input is invalid, because
C                            EPSABS.LE.0 AND
C                            EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28).
C                            RESULT, ABSERR and NEVAL are set to zero.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DQNG
C
      DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH,
     1  D1MACH,EPMACH,EPSABS,EPSREL,F,FCENTR,FVAL,FVAL1,FVAL2,FV1,FV2,
     2  FV3,FV4,HLGTH,RESULT,RES10,RES21,RES43,RES87,RESABS,RESASC,
     3  RESKH,SAVFUN,UFLOW,W10,W21A,W21B,W43A,W43B,W87A,W87B,X1,X2,X3,X4
      INTEGER IER,IPX,K,L,NEVAL
      EXTERNAL F
C
      DIMENSION FV1(5),FV2(5),FV3(5),FV4(5),X1(5),X2(5),X3(11),X4(22),
     1  W10(5),W21A(5),W21B(6),W43A(10),W43B(12),W87A(21),W87B(23),
     2  SAVFUN(21)
C
C           THE FOLLOWING DATA STATEMENTS CONTAIN THE
C           ABSCISSAE AND WEIGHTS OF THE INTEGRATION RULES USED.
C
C           X1      ABSCISSAE COMMON TO THE 10-, 21-, 43- AND 87-
C                   POINT RULE
C           X2      ABSCISSAE COMMON TO THE 21-, 43- AND 87-POINT RULE
C           X3      ABSCISSAE COMMON TO THE 43- AND 87-POINT RULE
C           X4      ABSCISSAE OF THE 87-POINT RULE
C           W10     WEIGHTS OF THE 10-POINT FORMULA
C           W21A    WEIGHTS OF THE 21-POINT FORMULA FOR ABSCISSAE X1
C           W21B    WEIGHTS OF THE 21-POINT FORMULA FOR ABSCISSAE X2
C           W43A    WEIGHTS OF THE 43-POINT FORMULA FOR ABSCISSAE X1, X3
C           W43B    WEIGHTS OF THE 43-POINT FORMULA FOR ABSCISSAE X3
C           W87A    WEIGHTS OF THE 87-POINT FORMULA FOR ABSCISSAE X1,
C                   X2, X3
C           W87B    WEIGHTS OF THE 87-POINT FORMULA FOR ABSCISSAE X4
C
C
C GAUSS-KRONROD-PATTERSON QUADRATURE COEFFICIENTS FOR USE IN
C QUADPACK ROUTINE QNG.  THESE COEFFICIENTS WERE CALCULATED WITH
C 101 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, BELL LABS, NOV 1981.
C
      SAVE X1, W10, X2, W21A, W21B, X3, W43A, W43B, X4, W87A, W87B
      DATA X1    (  1) / 0.9739065285 1717172007 7964012084 452 D0 /
      DATA X1    (  2) / 0.8650633666 8898451073 2096688423 493 D0 /
      DATA X1    (  3) / 0.6794095682 9902440623 4327365114 874 D0 /
      DATA X1    (  4) / 0.4333953941 2924719079 9265943165 784 D0 /
      DATA X1    (  5) / 0.1488743389 8163121088 4826001129 720 D0 /
      DATA W10   (  1) / 0.0666713443 0868813759 3568809893 332 D0 /
      DATA W10   (  2) / 0.1494513491 5058059314 5776339657 697 D0 /
      DATA W10   (  3) / 0.2190863625 1598204399 5534934228 163 D0 /
      DATA W10   (  4) / 0.2692667193 0999635509 1226921569 469 D0 /
      DATA W10   (  5) / 0.2955242247 1475287017 3892994651 338 D0 /
C
      DATA X2    (  1) / 0.9956571630 2580808073 5527280689 003 D0 /
      DATA X2    (  2) / 0.9301574913 5570822600 1207180059 508 D0 /
      DATA X2    (  3) / 0.7808177265 8641689706 3717578345 042 D0 /
      DATA X2    (  4) / 0.5627571346 6860468333 9000099272 694 D0 /
      DATA X2    (  5) / 0.2943928627 0146019813 1126603103 866 D0 /
      DATA W21A  (  1) / 0.0325581623 0796472747 8818972459 390 D0 /
      DATA W21A  (  2) / 0.0750396748 1091995276 7043140916 190 D0 /
      DATA W21A  (  3) / 0.1093871588 0229764189 9210590325 805 D0 /
      DATA W21A  (  4) / 0.1347092173 1147332592 8054001771 707 D0 /
      DATA W21A  (  5) / 0.1477391049 0133849137 4841515972 068 D0 /
      DATA W21B  (  1) / 0.0116946388 6737187427 8064396062 192 D0 /
      DATA W21B  (  2) / 0.0547558965 7435199603 1381300244 580 D0 /
      DATA W21B  (  3) / 0.0931254545 8369760553 5065465083 366 D0 /
      DATA W21B  (  4) / 0.1234919762 6206585107 7958109831 074 D0 /
      DATA W21B  (  5) / 0.1427759385 7706008079 7094273138 717 D0 /
      DATA W21B  (  6) / 0.1494455540 0291690566 4936468389 821 D0 /
C
      DATA X3    (  1) / 0.9993333609 0193208139 4099323919 911 D0 /
      DATA X3    (  2) / 0.9874334029 0808886979 5961478381 209 D0 /
      DATA X3    (  3) / 0.9548079348 1426629925 7919200290 473 D0 /
      DATA X3    (  4) / 0.9001486957 4832829362 5099494069 092 D0 /
      DATA X3    (  5) / 0.8251983149 8311415084 7066732588 520 D0 /
      DATA X3    (  6) / 0.7321483889 8930498261 2354848755 461 D0 /
      DATA X3    (  7) / 0.6228479705 3772523864 1159120344 323 D0 /
      DATA X3    (  8) / 0.4994795740 7105649995 2214885499 755 D0 /
      DATA X3    (  9) / 0.3649016613 4658076804 3989548502 644 D0 /
      DATA X3    ( 10) / 0.2222549197 7660129649 8260928066 212 D0 /
      DATA X3    ( 11) / 0.0746506174 6138332204 3914435796 506 D0 /
      DATA W43A  (  1) / 0.0162967342 8966656492 4281974617 663 D0 /
      DATA W43A  (  2) / 0.0375228761 2086950146 1613795898 115 D0 /
      DATA W43A  (  3) / 0.0546949020 5825544214 7212685465 005 D0 /
      DATA W43A  (  4) / 0.0673554146 0947808607 5553166302 174 D0 /
      DATA W43A  (  5) / 0.0738701996 3239395343 2140695251 367 D0 /
      DATA W43A  (  6) / 0.0057685560 5976979618 4184327908 655 D0 /
      DATA W43A  (  7) / 0.0273718905 9324884208 1276069289 151 D0 /
      DATA W43A  (  8) / 0.0465608269 1042883074 3339154433 824 D0 /
      DATA W43A  (  9) / 0.0617449952 0144256449 6240336030 883 D0 /
      DATA W43A  ( 10) / 0.0713872672 6869339776 8559114425 516 D0 /
      DATA W43B  (  1) / 0.0018444776 4021241410 0389106552 965 D0 /
      DATA W43B  (  2) / 0.0107986895 8589165174 0465406741 293 D0 /
      DATA W43B  (  3) / 0.0218953638 6779542810 2523123075 149 D0 /
      DATA W43B  (  4) / 0.0325974639 7534568944 3882222526 137 D0 /
      DATA W43B  (  5) / 0.0421631379 3519181184 7627924327 955 D0 /
      DATA W43B  (  6) / 0.0507419396 0018457778 0189020092 084 D0 /
      DATA W43B  (  7) / 0.0583793955 4261924837 5475369330 206 D0 /
      DATA W43B  (  8) / 0.0647464049 5144588554 4689259517 511 D0 /
      DATA W43B  (  9) / 0.0695661979 1235648452 8633315038 405 D0 /
      DATA W43B  ( 10) / 0.0728244414 7183320815 0939535192 842 D0 /
      DATA W43B  ( 11) / 0.0745077510 1417511827 3571813842 889 D0 /
      DATA W43B  ( 12) / 0.0747221475 1740300559 4425168280 423 D0 /
C
      DATA X4    (  1) / 0.9999029772 6272923449 0529830591 582 D0 /
      DATA X4    (  2) / 0.9979898959 8667874542 7496322365 960 D0 /
      DATA X4    (  3) / 0.9921754978 6068722280 8523352251 425 D0 /
      DATA X4    (  4) / 0.9813581635 7271277357 1916941623 894 D0 /
      DATA X4    (  5) / 0.9650576238 5838461912 8284110607 926 D0 /
      DATA X4    (  6) / 0.9431676131 3367059681 6416634507 426 D0 /
      DATA X4    (  7) / 0.9158064146 8550720959 1826430720 050 D0 /
      DATA X4    (  8) / 0.8832216577 7131650137 2117548744 163 D0 /
      DATA X4    (  9) / 0.8457107484 6241566660 5902011504 855 D0 /
      DATA X4    ( 10) / 0.8035576580 3523098278 8739474980 964 D0 /
      DATA X4    ( 11) / 0.7570057306 8549555832 8942793432 020 D0 /
      DATA X4    ( 12) / 0.7062732097 8732181982 4094274740 840 D0 /
      DATA X4    ( 13) / 0.6515894665 0117792253 4422205016 736 D0 /
      DATA X4    ( 14) / 0.5932233740 5796108887 5273770349 144 D0 /
      DATA X4    ( 15) / 0.5314936059 7083193228 5268948562 671 D0 /
      DATA X4    ( 16) / 0.4667636230 4202284487 1966781659 270 D0 /
      DATA X4    ( 17) / 0.3994248478 5921880473 2101665817 923 D0 /
      DATA X4    ( 18) / 0.3298748771 0618828826 5053371824 597 D0 /
      DATA X4    ( 19) / 0.2585035592 0216155180 2280975429 025 D0 /
      DATA X4    ( 20) / 0.1856953965 6834665201 5917141167 606 D0 /
      DATA X4    ( 21) / 0.1118422131 7990746817 2398359241 362 D0 /
      DATA X4    ( 22) / 0.0373521233 9461987081 4998165437 704 D0 /
      DATA W87A  (  1) / 0.0081483773 8414917290 0002878448 190 D0 /
      DATA W87A  (  2) / 0.0187614382 0156282224 3935059003 794 D0 /
      DATA W87A  (  3) / 0.0273474510 5005228616 1582829741 283 D0 /
      DATA W87A  (  4) / 0.0336777073 1163793004 6581056957 588 D0 /
      DATA W87A  (  5) / 0.0369350998 2042790761 4589586742 499 D0 /
      DATA W87A  (  6) / 0.0028848724 3021153050 1334156248 695 D0 /
      DATA W87A  (  7) / 0.0136859460 2271270188 8950035273 128 D0 /
      DATA W87A  (  8) / 0.0232804135 0288831112 3409291030 404 D0 /
      DATA W87A  (  9) / 0.0308724976 1171335867 5466394126 442 D0 /
      DATA W87A  ( 10) / 0.0356936336 3941877071 9351355457 044 D0 /
      DATA W87A  ( 11) / 0.0009152833 4520224136 0843392549 948 D0 /
      DATA W87A  ( 12) / 0.0053992802 1930047136 7738743391 053 D0 /
      DATA W87A  ( 13) / 0.0109476796 0111893113 4327826856 808 D0 /
      DATA W87A  ( 14) / 0.0162987316 9678733526 2665703223 280 D0 /
      DATA W87A  ( 15) / 0.0210815688 8920383511 2433060188 190 D0 /
      DATA W87A  ( 16) / 0.0253709697 6925382724 3467999831 710 D0 /
      DATA W87A  ( 17) / 0.0291896977 5647575250 1446154084 920 D0 /
      DATA W87A  ( 18) / 0.0323732024 6720278968 5788194889 595 D0 /
      DATA W87A  ( 19) / 0.0347830989 5036514275 0781997949 596 D0 /
      DATA W87A  ( 20) / 0.0364122207 3135178756 2801163687 577 D0 /
      DATA W87A  ( 21) / 0.0372538755 0304770853 9592001191 226 D0 /
      DATA W87B  (  1) / 0.0002741455 6376207235 0016527092 881 D0 /
      DATA W87B  (  2) / 0.0018071241 5505794294 8341311753 254 D0 /
      DATA W87B  (  3) / 0.0040968692 8275916486 4458070683 480 D0 /
      DATA W87B  (  4) / 0.0067582900 5184737869 9816577897 424 D0 /
      DATA W87B  (  5) / 0.0095499576 7220164653 6053581325 377 D0 /
      DATA W87B  (  6) / 0.0123294476 5224485369 4626639963 780 D0 /
      DATA W87B  (  7) / 0.0150104473 4638895237 6697286041 943 D0 /
      DATA W87B  (  8) / 0.0175489679 8624319109 9665352925 900 D0 /
      DATA W87B  (  9) / 0.0199380377 8644088820 2278192730 714 D0 /
      DATA W87B  ( 10) / 0.0221949359 6101228679 6332102959 499 D0 /
      DATA W87B  ( 11) / 0.0243391471 2600080547 0360647041 454 D0 /
      DATA W87B  ( 12) / 0.0263745054 1483920724 1503786552 615 D0 /
      DATA W87B  ( 13) / 0.0282869107 8877120065 9968002987 960 D0 /
      DATA W87B  ( 14) / 0.0300525811 2809269532 2521110347 341 D0 /
      DATA W87B  ( 15) / 0.0316467513 7143992940 4586051078 883 D0 /
      DATA W87B  ( 16) / 0.0330504134 1997850329 0785944862 689 D0 /
      DATA W87B  ( 17) / 0.0342550997 0422606178 7082821046 821 D0 /
      DATA W87B  ( 18) / 0.0352624126 6015668103 3782717998 428 D0 /
      DATA W87B  ( 19) / 0.0360769896 2288870118 5500318003 895 D0 /
      DATA W87B  ( 20) / 0.0366986044 9845609449 8018047441 094 D0 /
      DATA W87B  ( 21) / 0.0371205492 6983257611 4119958413 599 D0 /
      DATA W87B  ( 22) / 0.0373342287 5193504032 1235449094 698 D0 /
      DATA W87B  ( 23) / 0.0373610737 6267902341 0321241766 599 D0 /
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTEGRATION INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTEGRATION INTERVAL
C           FCENTR - FUNCTION VALUE AT MID POINT
C           ABSC   - ABSCISSA
C           FVAL   - FUNCTION VALUE
C           SAVFUN - ARRAY OF FUNCTION VALUES WHICH HAVE ALREADY BEEN
C                    COMPUTED
C           RES10  - 10-POINT GAUSS RESULT
C           RES21  - 21-POINT KRONROD RESULT
C           RES43  - 43-POINT RESULT
C           RES87  - 87-POINT RESULT
C           RESABS - APPROXIMATION TO THE INTEGRAL OF ABS(F)
C           RESASC - APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQNG
      EPMACH = D1MACH(4)
      UFLOW = D1MACH(1)
C
C           TEST ON VALIDITY OF PARAMETERS
C           ------------------------------
C
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      NEVAL = 0
      IER = 6
      IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28))
     1  GO TO 80
      HLGTH = 0.5D+00*(B-A)
      DHLGTH = ABS(HLGTH)
      CENTR = 0.5D+00*(B+A)
      FCENTR = F(CENTR)
      NEVAL = 21
      IER = 1
C
C          COMPUTE THE INTEGRAL USING THE 10- AND 21-POINT FORMULA.
C
      DO 70 L = 1,3
      GO TO (5,25,45),L
    5 RES10 = 0.0D+00
      RES21 = W21B(6)*FCENTR
      RESABS = W21B(6)*ABS(FCENTR)
      DO 10 K=1,5
        ABSC = HLGTH*X1(K)
        FVAL1 = F(CENTR+ABSC)
        FVAL2 = F(CENTR-ABSC)
        FVAL = FVAL1+FVAL2
        RES10 = RES10+W10(K)*FVAL
        RES21 = RES21+W21A(K)*FVAL
        RESABS = RESABS+W21A(K)*(ABS(FVAL1)+ABS(FVAL2))
        SAVFUN(K) = FVAL
        FV1(K) = FVAL1
        FV2(K) = FVAL2
   10 CONTINUE
      IPX = 5
      DO 15 K=1,5
        IPX = IPX+1
        ABSC = HLGTH*X2(K)
        FVAL1 = F(CENTR+ABSC)
        FVAL2 = F(CENTR-ABSC)
        FVAL = FVAL1+FVAL2
        RES21 = RES21+W21B(K)*FVAL
        RESABS = RESABS+W21B(K)*(ABS(FVAL1)+ABS(FVAL2))
        SAVFUN(IPX) = FVAL
        FV3(K) = FVAL1
        FV4(K) = FVAL2
   15 CONTINUE
C
C          TEST FOR CONVERGENCE.
C
      RESULT = RES21*HLGTH
      RESABS = RESABS*DHLGTH
      RESKH = 0.5D+00*RES21
      RESASC = W21B(6)*ABS(FCENTR-RESKH)
      DO 20 K = 1,5
        RESASC = RESASC+W21A(K)*(ABS(FV1(K)-RESKH)+ABS(FV2(K)-RESKH))
     1                  +W21B(K)*(ABS(FV3(K)-RESKH)+ABS(FV4(K)-RESKH))
   20 CONTINUE
      ABSERR = ABS((RES21-RES10)*HLGTH)
      RESASC = RESASC*DHLGTH
      GO TO 65
C
C          COMPUTE THE INTEGRAL USING THE 43-POINT FORMULA.
C
   25 RES43 = W43B(12)*FCENTR
      NEVAL = 43
      DO 30 K=1,10
        RES43 = RES43+SAVFUN(K)*W43A(K)
   30 CONTINUE
      DO 40 K=1,11
        IPX = IPX+1
        ABSC = HLGTH*X3(K)
        FVAL = F(ABSC+CENTR)+F(CENTR-ABSC)
        RES43 = RES43+FVAL*W43B(K)
        SAVFUN(IPX) = FVAL
   40 CONTINUE
C
C          TEST FOR CONVERGENCE.
C
      RESULT = RES43*HLGTH
      ABSERR = ABS((RES43-RES21)*HLGTH)
      GO TO 65
C
C          COMPUTE THE INTEGRAL USING THE 87-POINT FORMULA.
C
   45 RES87 = W87B(23)*FCENTR
      NEVAL = 87
      DO 50 K=1,21
        RES87 = RES87+SAVFUN(K)*W87A(K)
   50 CONTINUE
      DO 60 K=1,22
        ABSC = HLGTH*X4(K)
        RES87 = RES87+W87B(K)*(F(ABSC+CENTR)+F(CENTR-ABSC))
   60 CONTINUE
      RESULT = RES87*HLGTH
      ABSERR = ABS((RES87-RES43)*HLGTH)
   65 IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
     1  ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
      IF (RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX
     1  ((EPMACH*0.5D+02)*RESABS,ABSERR)
      IF (ABSERR.LE.MAX(EPSABS,EPSREL*ABS(RESULT))) IER = 0
C ***JUMP OUT OF DO-LOOP
      IF (IER.EQ.0) GO TO 999
   70 CONTINUE
   80 CALL XERMSG ('SLATEC', 'DQNG', 'ABNORMAL RETURN', IER, 0)
  999 RETURN
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file shsgs.f
c
c     this file contains code and documentation for subroutines
c     shsgs and shsgsi
c
c ... files which must be loaded with shsgs.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine shsgs(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    1                    wshsgs,lshsgs,work,lwork,ierror)
c
c     subroutine shsgs performs the spherical harmonic synthesis
c     on the arrays a and b and stores the result in the array g.
c     the synthesis is performed on an equally spaced longitude grid
c     and a gaussian colatitude grid.  the associated legendre functions
c     are stored rather than recomputed as they are in subroutine
c     shsgc.  the synthesis is described below at output parameter
c     g.
c
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the synthesis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the synthesis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of syntheses.  in the program that calls shsgs,
c            the arrays g,a and b can be three dimensional in which
c            case multiple synthesis will be performed.  the third
c            index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shagc. if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg must
c            be at least nlat/2 if nlat is even or at least (nlat+1)/2
c            if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shagc. jdg must be at least nlon.
c
c     a,b    two or three dimensional arrays (see the input parameter
c            nt) that contain the coefficients in the spherical harmonic
c            expansion of g(i,j) given below at the definition of the
c            output parameter g.  a(m,n) and b(m,n) are defined for
c            indices m=1,...,mmax and n=m,...,nlat where mmax is the
c            maximum (plus one) longitudinal wave number given by
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shsgs. mdab must be at least
c            min0((nlon+2)/2,nlat) if nlon is even or at least
c            min0((nlon+1)/2,nlat) if nlon is odd.
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shsgs. ndab must be at least nlat
c
c     wshsgs an array which must be initialized by subroutine shsgsi.
c            once initialized, wshsgs can be used repeatedly by shsgs
c            as long as nlat and nlon remain unchanged.  wshsgs must
c            not be altered between calls of shsgs.
c
c     lshsgs the dimension of the array wshsgs as it appears in the
c            program that calls shsgs. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgs must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shsgs. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c
c            if isym is zero then lwork must be at least
c
c                  nlat*nlon*(nt+1)
c
c            if isym is nonzero then lwork must be at least
c
c                  l2*nlon*(nt+1)
c
c
c     **************************************************************
c
c     output parameters
c
c     g      a two or three dimensional array (see input parameter nt)
c            that contains the discrete function which is synthesized.
c            g(i,j) contains the value of the function at the gaussian
c            colatitude point theta(i) and longitude point
c            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
c            above at the input parameter isym.  for isym=0, g(i,j)
c            is given by the the equations listed below.  symmetric
c            versions are used when isym is greater than zero.
c
c     the normalized associated legendre functions are given by
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta)
c
c     define the maximum (plus one) longitudinal wave number
c     as   mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c          mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     then g(i,j) = the sum from n=0 to n=nlat-1 of
c
c                   .5*pbar(0,n,theta(i))*a(1,n+1)
c
c              plus the sum from m=1 to m=mmax-1 of
c
c                   the sum from n=m to n=nlat-1 of
c
c              pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j))
c                                    -b(m+1,n+1)*sin(m*phi(j)))
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshsgs
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c
c     subroutine shsgsi(nlat,nlon,wshsgs,lshsgs,work,lwork,dwork,ldwork,
c    +                  ierror)
c
c     subroutine shsgsi initializes the array wshsgs which can then
c     be used repeatedly by subroutines shsgs. it precomputes
c     and stores in wshsgs quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshsgs an array which must be initialized by subroutine shsgsi.
c            once initialized, wshsgs can be used repeatedly by shsgs
c            as long as nlat and nlon remain unchanged.  wshsgs must
c            not be altered between calls of shsgs.
c
c     lshsgs the dimension of the array wshsgs as it appears in the
c            program that calls shsgs. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgs must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c     work   a real work space which need not be saved
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shsgsi. lwork must be at least
c            4*nlat*(nlat+2)+2 in the routine calling shsgsi
c
C*PL*ERROR* Comment line too long
c     dwork   a double precision work array that does not have to be saved.
c
c     ldwork  the length of dwork in the calling routine.  ldwork must
c             be at least nlat*(nlat+4)
c
c     output parameter
c
c     wshsgs an array which must be initialized before calling shsgs or
c            once initialized, wshsgs can be used repeatedly by shsgs or
c            as long as nlat and nlon remain unchanged.  wshsgs must not
c            altered between calls of shsgs.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshsgs
c            = 4  error in the specification of lwork
c            = 5  error in the specification of ldwork
c            = 5  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
      SUBROUTINE DSHSGS(NLAT,NLON,MODE,NT,G,IDG,JDG,A,B,MDAB,NDAB,
     +                  WSHSGS,LSHSGS,WORK,LWORK,IERROR)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHSGS
      DOUBLE PRECISION WORK
      DIMENSION G(IDG,JDG,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),
     +          WSHSGS(LSHSGS),WORK(LWORK)
c     check input parameters
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (MODE.LT.0 .OR. MODE.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.1) RETURN
c     set limit on m subscript
      L = MIN0((NLON+2)/2,NLAT)
c     set gaussian point nearest equator pointer
      LATE = (NLAT+MOD(NLAT,2))/2
c     set number of grid points for analysis/synthesis
      LAT = NLAT
      IF (MODE.NE.0) LAT = LATE
      IERROR = 5
      IF (IDG.LT.LAT) RETURN
      IERROR = 6
      IF (JDG.LT.NLON) RETURN
      IERROR = 7
      IF (MDAB.LT.L) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      L1 = L
      L2 = LATE
      IERROR = 9
c     check permanent work space length
      LP = NLAT* (3* (L1+L2)-2) + (L1-1)* (L2* (2*NLAT-L1)-3*L1)/2 +
     +     NLON + 15
      IF (LSHSGS.LT.LP) RETURN
c     check temporary work space length
      IERROR = 10
      IF (MODE.EQ.0 .AND. LWORK.LT.NLAT*NLON* (NT+1)) RETURN
      IF (MODE.NE.0 .AND. LWORK.LT.L2*NLON* (NT+1)) RETURN
      IERROR = 0
c     starting address for fft values and legendre polys in wshsgs
      IFFT = NLAT + 2*NLAT*LATE + 3* (L* (L-1)/2+ (NLAT-L)* (L-1)) + 1
      IPMN = IFFT + NLON + 15
c     set pointer for internal storage of g
      IW = LAT*NLON*NT + 1
      CALL DSHSGS1(NLAT,NLON,L,LAT,MODE,G,IDG,JDG,NT,A,B,MDAB,NDAB,
     +             WSHSGS(IFFT),WSHSGS(IPMN),LATE,WORK,WORK(IW))
      RETURN
      END

      SUBROUTINE DSHSGS1(NLAT,NLON,L,LAT,MODE,GS,IDG,JDG,NT,A,B,MDAB,
     +                   NDAB,WFFT,PMN,LATE,G,WORK)
      DOUBLE PRECISION GS
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION PMN
      DOUBLE PRECISION G
      DOUBLE PRECISION WORK
      DOUBLE PRECISION T1
      DOUBLE PRECISION T3
      DOUBLE PRECISION T2
      DOUBLE PRECISION T4
      DIMENSION GS(IDG,JDG,NT),A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)
      DIMENSION WFFT(1),PMN(LATE,1),G(LAT,NLON,NT),WORK(1)

c     reconstruct fourier coefficients in g on gaussian grid
c     using coefficients in a,b

c     initialize to zero
      DO 100 K = 1,NT
          DO 100 J = 1,NLON
              DO 100 I = 1,LAT
                  G(I,J,K) = 0.0D0
  100 CONTINUE

      LM1 = L
      IF (NLON.EQ.L+L-2) LM1 = L - 1
      IF (MODE.EQ.0) THEN
c     set first column in g
          M = 0
          MML1 = M* (2*NLAT-M-1)/2
          DO 101 K = 1,NT
c     n even
              DO 102 NP1 = 1,NLAT,2
                  MN = MML1 + NP1
                  DO 102 I = 1,LATE
                      G(I,1,K) = G(I,1,K) + A(1,NP1,K)*PMN(I,MN)
  102         CONTINUE
c     n odd
              NL2 = NLAT/2
              DO 103 NP1 = 2,NLAT,2
                  MN = MML1 + NP1
                  DO 103 I = 1,NL2
                      IS = NLAT - I + 1
                      G(IS,1,K) = G(IS,1,K) + A(1,NP1,K)*PMN(I,MN)
  103         CONTINUE
  101     CONTINUE

c     restore m=0 coefficients from odd/even
          DO 112 K = 1,NT
              DO 112 I = 1,NL2
                  IS = NLAT - I + 1
                  T1 = G(I,1,K)
                  T3 = G(IS,1,K)
                  G(I,1,K) = T1 + T3
                  G(IS,1,K) = T1 - T3
  112     CONTINUE

c     sweep interior columns of g
          DO 104 MP1 = 2,LM1
              M = MP1 - 1
              MML1 = M* (2*NLAT-M-1)/2
              MP2 = M + 2
              DO 105 K = 1,NT
C*PL*ERROR* Comment line too long
c     for n-m even store (g(i,p,k)+g(nlat-i+1,p,k))/2 in g(i,p,k) p=2*m,2*m+1
c     for i=1,...,late
                  DO 106 NP1 = MP1,NLAT,2
                      MN = MML1 + NP1
                      DO 107 I = 1,LATE
                          G(I,2*M,K) = G(I,2*M,K) +
     +                                 A(MP1,NP1,K)*PMN(I,MN)
                          G(I,2*M+1,K) = G(I,2*M+1,K) +
     +                                   B(MP1,NP1,K)*PMN(I,MN)
  107                 CONTINUE
  106             CONTINUE

c     for n-m odd store g(i,p,k)-g(nlat-i+1,p,k) in g(nlat-i+1,p,k)
c     for i=1,...,nlat/2 (p=2*m,p=2*m+1)
                  DO 108 NP1 = MP2,NLAT,2
                      MN = MML1 + NP1
                      DO 109 I = 1,NL2
                          IS = NLAT - I + 1
                          G(IS,2*M,K) = G(IS,2*M,K) +
     +                                  A(MP1,NP1,K)*PMN(I,MN)
                          G(IS,2*M+1,K) = G(IS,2*M+1,K) +
     +                                    B(MP1,NP1,K)*PMN(I,MN)
  109                 CONTINUE
  108             CONTINUE

c     now set fourier coefficients using even-odd reduction above
                  DO 110 I = 1,NL2
                      IS = NLAT - I + 1
                      T1 = G(I,2*M,K)
                      T2 = G(I,2*M+1,K)
                      T3 = G(IS,2*M,K)
                      T4 = G(IS,2*M+1,K)
                      G(I,2*M,K) = T1 + T3
                      G(I,2*M+1,K) = T2 + T4
                      G(IS,2*M,K) = T1 - T3
                      G(IS,2*M+1,K) = T2 - T4
  110             CONTINUE

  105         CONTINUE
  104     CONTINUE

c     set last column (using a only) if necessary
          IF (NLON.EQ.L+L-2) THEN
              M = L - 1
              MML1 = M* (2*NLAT-M-1)/2
              DO 111 K = 1,NT
c     n-m even
                  DO 131 NP1 = L,NLAT,2
                      MN = MML1 + NP1
                      DO 131 I = 1,LATE
                          G(I,NLON,K) = G(I,NLON,K) +
     +                                  2.0D0*A(L,NP1,K)*PMN(I,MN)

  131             CONTINUE
                  LP1 = L + 1
c     n-m odd
                  DO 132 NP1 = LP1,NLAT,2
                      MN = MML1 + NP1
                      DO 132 I = 1,NL2
                          IS = NLAT - I + 1
                          G(IS,NLON,K) = G(IS,NLON,K) +
     +                                   2.0D0*A(L,NP1,K)*PMN(I,MN)
  132             CONTINUE
                  DO 133 I = 1,NL2
                      IS = NLAT - I + 1
                      T1 = G(I,NLON,K)
                      T3 = G(IS,NLON,K)
                      G(I,NLON,K) = T1 + T3
                      G(IS,NLON,K) = T1 - T3
  133             CONTINUE
  111         CONTINUE
          END IF

      ELSE
c     half sphere (mode.ne.0)
c     set first column in g
          M = 0
          MML1 = M* (2*NLAT-M-1)/2
          MEO = 1
          IF (MODE.EQ.1) MEO = 2
          MS = M + MEO
          DO 113 K = 1,NT
              DO 113 NP1 = MS,NLAT,2
                  MN = MML1 + NP1
                  DO 113 I = 1,LATE
                      G(I,1,K) = G(I,1,K) + A(1,NP1,K)*PMN(I,MN)
  113     CONTINUE

c     sweep interior columns of g

          DO 114 MP1 = 2,LM1
              M = MP1 - 1
              MML1 = M* (2*NLAT-M-1)/2
              MS = M + MEO
              DO 115 K = 1,NT
                  DO 115 NP1 = MS,NLAT,2
                      MN = MML1 + NP1
                      DO 115 I = 1,LATE
                          G(I,2*M,K) = G(I,2*M,K) +
     +                                 A(MP1,NP1,K)*PMN(I,MN)
                          G(I,2*M+1,K) = G(I,2*M+1,K) +
     +                                   B(MP1,NP1,K)*PMN(I,MN)
  115         CONTINUE
  114     CONTINUE

          IF (NLON.EQ.L+L-2) THEN
c     set last column
              M = L - 1
              MML1 = M* (2*NLAT-M-1)/2
              NS = L
              IF (MODE.EQ.1) NS = L + 1
              DO 116 K = 1,NT
                  DO 116 NP1 = NS,NLAT,2
                      MN = MML1 + NP1
                      DO 116 I = 1,LATE
                          G(I,NLON,K) = G(I,NLON,K) +
     +                                  2.0D0*A(L,NP1,K)*PMN(I,MN)
  116         CONTINUE
          END IF

      END IF

c     do inverse fourier transform
      DO 120 K = 1,NT
          CALL DHRFFTB(LAT,NLON,G(1,1,K),LAT,WFFT,WORK)
  120 CONTINUE
c     scale output in gs
      DO 122 K = 1,NT
          DO 122 J = 1,NLON
              DO 122 I = 1,LAT
                  GS(I,J,K) = 0.5D0*G(I,J,K)
  122 CONTINUE

      RETURN
      END
      SUBROUTINE DSHSGSI(NLAT,NLON,WSHSGS,LSHSGS,WORK,LWORK,DWORK,
     +                   LDWORK,IERROR)
      DOUBLE PRECISION WSHSGS
      DOUBLE PRECISION WORK
c
c     this subroutine must be called before calling shags or shsgs with
c     fixed nlat,nlon. it precomputes the gaussian weights, points
c     and all necessary legendre polys and stores them in wshsgs.
c     these quantities must be preserved when calling shsgs
c     repeatedly with fixed nlat,nlon.
c
      DIMENSION WSHSGS(LSHSGS),WORK(LWORK)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+1)/2
      L1 = L
      L2 = LATE
c     check permanent work space length
      IERROR = 3
      LP = NLAT* (3* (L1+L2)-2) + (L1-1)* (L2* (2*NLAT-L1)-3*L1)/2 +
     +     NLON + 15
      IF (LSHSGS.LT.LP) RETURN
      IERROR = 4
c     check temporary work space
      IF (LWORK.LT.4*NLAT* (NLAT+2)+2) RETURN
      IERROR = 5
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
C*PL*ERROR* Comment line too long
c     set preliminary quantites needed to compute and store legendre polys
      LDW = NLAT* (NLAT+4)
      CALL DSHSGSP(NLAT,NLON,WSHSGS,LSHSGS,DWORK,LDWORK,IERROR)
      IF (IERROR.NE.0) RETURN
c     set legendre poly pointer in wshsgs
      IPMNF = NLAT + 2*NLAT*LATE + 3* (L* (L-1)/2+ (NLAT-L)* (L-1)) +
     +        NLON + 16
      CALL DSHSGSS1(NLAT,L,LATE,WSHSGS,WORK,WSHSGS(IPMNF))
      RETURN
      END
      SUBROUTINE DSHSGSS1(NLAT,L,LATE,W,PMN,PMNF)
      DOUBLE PRECISION W
      DOUBLE PRECISION PMN
      DOUBLE PRECISION PMNF
      DIMENSION W(1),PMN(NLAT,LATE,3),PMNF(LATE,1)
c     compute and store legendre polys for i=1,...,late,m=0,...,l-1
c     and n=m,...,l-1
      DO I = 1,NLAT
          DO J = 1,LATE
              DO K = 1,3
                  PMN(I,J,K) = 0.0D0
              END DO
          END DO
      END DO
      DO 100 MP1 = 1,L
          M = MP1 - 1
          MML1 = M* (2*NLAT-M-1)/2
c     compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2
          MODE = 0
          CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
c     store above in pmnf
          DO 101 NP1 = MP1,NLAT
              MN = MML1 + NP1
              DO 102 I = 1,LATE
                  PMNF(I,MN) = PMN(NP1,I,KM)
  102         CONTINUE
  101     CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DSHSGSP(NLAT,NLON,WSHSGS,LSHSGS,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHSGS
      DIMENSION WSHSGS(LSHSGS)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+MOD(NLAT,2))/2
      L1 = L
      L2 = LATE
      IERROR = 3
c     check permanent work space length
      IF (LSHSGS.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 4
c     if (lwork.lt.4*nlat*(nlat+2)+2) return
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
c     set pointers
      I1 = 1
      I2 = I1 + NLAT
      I3 = I2 + NLAT*LATE
      I4 = I3 + NLAT*LATE
      I5 = I4 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I6 = I5 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I7 = I6 + L* (L-1)/2 + (NLAT-L)* (L-1)
c     set indices in temp work for double precision gaussian wts and pts
      IDTH = 1
c     idwts = idth+2*nlat
c     iw = idwts+2*nlat
      IDWTS = IDTH + NLAT
      IW = IDWTS + NLAT
      CALL DSHSGSP1(NLAT,NLON,L,LATE,WSHSGS(I1),WSHSGS(I2),WSHSGS(I3),
     +              WSHSGS(I4),WSHSGS(I5),WSHSGS(I6),WSHSGS(I7),
     +              DWORK(IDTH),DWORK(IDWTS),DWORK(IW),IERROR)
      IF (IERROR.NE.0) IERROR = 6
      RETURN
      END
      SUBROUTINE DSHSGSP1(NLAT,NLON,L,LATE,WTS,P0N,P1N,ABEL,BBEL,CBEL,
     +                    WFFT,DTHETA,DWTS,WORK,IER)
      DOUBLE PRECISION WTS
      DOUBLE PRECISION P0N
      DOUBLE PRECISION P1N
      DOUBLE PRECISION ABEL
      DOUBLE PRECISION BBEL
      DOUBLE PRECISION CBEL
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION FN
      DOUBLE PRECISION FM
      DIMENSION WTS(NLAT),P0N(NLAT,LATE),P1N(NLAT,LATE),ABEL(1),BBEL(1),
     +          CBEL(1),WFFT(1),DTHETA(NLAT),DWTS(NLAT)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION PB,DTHETA,DWTS,WORK(*)

      INDX(M,N) = (N-1)* (N-2)/2 + M - 1
      IMNDX(M,N) = L* (L-1)/2 + (N-L-1)* (L-1) + M - 1
      CALL DHRFFTI(NLON,WFFT)
c
c     compute double precision gaussian points and weights
c
      LW = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHETA,DWTS,WORK,LW,IER)
      IF (IER.NE.0) RETURN

c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      DO 100 I = 1,NLAT
          WTS(I) = DWTS(I)
  100 CONTINUE

c     initialize p0n,p1n using double precision dnlfk,dnlft
      DO 101 NP1 = 1,NLAT
          DO 101 I = 1,LATE
              P0N(NP1,I) = 0.0D0
              P1N(NP1,I) = 0.0D0
  101 CONTINUE
c     compute m=n=0 legendre polynomials for all theta(i)
      NP1 = 1
      N = 0
      M = 0
      CALL DDNLFK(M,N,WORK)
      DO 103 I = 1,LATE
          CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
          P0N(1,I) = PB
  103 CONTINUE
c     compute p0n,p1n for all theta(i) when n.gt.0
      DO 104 NP1 = 2,NLAT
          N = NP1 - 1
          M = 0
          CALL DDNLFK(M,N,WORK)
          DO 105 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P0N(NP1,I) = PB
  105     CONTINUE
c     compute m=1 legendre polynomials for all n and theta(i)
          M = 1
          CALL DDNLFK(M,N,WORK)
          DO 106 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P1N(NP1,I) = PB
  106     CONTINUE
  104 CONTINUE
c
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      DO 107 N = 2,NLAT
          FN = DBLE(N)
          MLIM = MIN0(N,L)
          DO 107 M = 2,MLIM
              FM = DBLE(M)
              IMN = INDX(M,N)
              IF (N.GE.L) IMN = IMNDX(M,N)
              ABEL(IMN) = SQRT(((2*FN+1)* (FM+FN-2)* (FM+FN-3))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              BBEL(IMN) = SQRT(((2*FN+1)* (FN-FM-1)* (FN-FM))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              CBEL(IMN) = SQRT(((FN-FM+1)* (FN-FM+2))/
     +                    (((FN+FM-1)* (FN+FM))))
  107 CONTINUE
      RETURN
      END


! RUN: bbc -emit-fir %s -o - | FileCheck %s
! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s

! Test matmul intrinsic

! CHECK-LABEL: matmul_test
! CHECK-SAME: (%[[X:.*]]: !fir.ref<!fir.array<3x1xf32>>{{.*}}, %[[Y:.*]]: !fir.ref<!fir.array<1x3xf32>>{{.*}}, %[[Z:.*]]: !fir.ref<!fir.array<2x2xf32>>{{.*}})
! CHECK:  %[[RESULT_BOX_ADDR:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?xf32>>>
! CHECK:  %[[C3:.*]] = arith.constant 3 : index
! CHECK:  %[[C1:.*]] = arith.constant 1 : index
! CHECK:  %[[C1_0:.*]] = arith.constant 1 : index
! CHECK:  %[[C3_1:.*]] = arith.constant 3 : index
! CHECK:  %[[Z_BOX:.*]] = fir.array_load %[[Z]]({{.*}}) : (!fir.ref<!fir.array<2x2xf32>>, !fir.shape<2>) -> !fir.array<2x2xf32>
! CHECK:  %[[X_SHAPE:.*]] = fir.shape %[[C3]], %[[C1]] : (index, index) -> !fir.shape<2>
! CHECK:  %[[X_BOX:.*]] = fir.embox %[[X]](%[[X_SHAPE]]) : (!fir.ref<!fir.array<3x1xf32>>, !fir.shape<2>) -> !fir.box<!fir.array<3x1xf32>>
! CHECK:  %[[Y_SHAPE:.*]] = fir.shape %[[C1_0]], %[[C3_1]] : (index, index) -> !fir.shape<2>
! CHECK:  %[[Y_BOX:.*]] = fir.embox %[[Y]](%[[Y_SHAPE]]) : (!fir.ref<!fir.array<1x3xf32>>, !fir.shape<2>) -> !fir.box<!fir.array<1x3xf32>>
! CHECK:  %[[ZERO_INIT:.*]] = fir.zero_bits !fir.heap<!fir.array<?x?xf32>>
! CHECK:  %[[C0:.*]] = arith.constant 0 : index
! CHECK:  %[[RESULT_SHAPE:.*]] = fir.shape %[[C0]], %[[C0]] : (index, index) -> !fir.shape<2>
! CHECK:  %[[RESULT_BOX_VAL:.*]] = fir.embox %[[ZERO_INIT]](%[[RESULT_SHAPE]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
! CHECK:  fir.store %[[RESULT_BOX_VAL]] to %[[RESULT_BOX_ADDR]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK:  %[[RESULT_BOX_ADDR_RUNTIME:.*]] = fir.convert %[[RESULT_BOX_ADDR]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK:  %[[X_BOX_RUNTIME:.*]] = fir.convert %[[X_BOX]] : (!fir.box<!fir.array<3x1xf32>>) -> !fir.box<none>
! CHECK:  %[[Y_BOX_RUNTIME:.*]] = fir.convert %[[Y_BOX]] : (!fir.box<!fir.array<1x3xf32>>) -> !fir.box<none>
! CHECK:  {{.*}}fir.call @_FortranAMatmul(%[[RESULT_BOX_ADDR_RUNTIME]], %[[X_BOX_RUNTIME]], %[[Y_BOX_RUNTIME]], {{.*}}, {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, i32) -> none
! CHECK:  %[[RESULT_BOX:.*]] = fir.load %[[RESULT_BOX_ADDR]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK:  %[[RESULT_TMP:.*]] = fir.box_addr %[[RESULT_BOX]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>) -> !fir.heap<!fir.array<?x?xf32>>
! CHECK:  %[[Z_COPY_FROM_RESULT:.*]] = fir.do_loop
! CHECK:    {{.*}}fir.array_fetch
! CHECK:    {{.*}}fir.array_update
! CHECK:    fir.result
! CHECK:  }
! CHECK:  fir.array_merge_store %[[Z_BOX]], %[[Z_COPY_FROM_RESULT]] to %[[Z]] : !fir.array<2x2xf32>, !fir.array<2x2xf32>, !fir.ref<!fir.array<2x2xf32>>
! CHECK:  fir.freemem %[[RESULT_TMP]] : !fir.heap<!fir.array<?x?xf32>>
subroutine matmul_test(x,y,z)
  real :: x(3,1), y(1,3), z(2,2)
  z = matmul(x,y)
end subroutine

! CHECK-LABEL: matmul_test2
! CHECK-SAME: (%[[X_BOX:.*]]: !fir.box<!fir.array<?x?x!fir.logical<4>>>{{.*}}, %[[Y_BOX:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>{{.*}}, %[[Z_BOX:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>{{.*}})
!CHECK:  %[[RESULT_BOX_ADDR:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>
!CHECK:  %[[Z:.*]] = fir.array_load %[[Z_BOX]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.array<?x!fir.logical<4>>
!CHECK:  %[[ZERO_INIT:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.logical<4>>>
!CHECK:  %[[C0:.*]] = arith.constant 0 : index
!CHECK:  %[[RESULT_SHAPE:.*]] = fir.shape %[[C0]] : (index) -> !fir.shape<1>
!CHECK:  %[[RESULT_BOX:.*]] = fir.embox %[[ZERO_INIT]](%[[RESULT_SHAPE]]) : (!fir.heap<!fir.array<?x!fir.logical<4>>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>
!CHECK:  fir.store %[[RESULT_BOX]] to %[[RESULT_BOX_ADDR]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>>
!CHECK:  %[[RESULT_BOX_RUNTIME:.*]] = fir.convert %[[RESULT_BOX_ADDR]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>>) -> !fir.ref<!fir.box<none>>
!CHECK:  %[[X_BOX_RUNTIME:.*]] = fir.convert %[[X_BOX]] : (!fir.box<!fir.array<?x?x!fir.logical<4>>>) -> !fir.box<none>
!CHECK:  %[[Y_BOX_RUNTIME:.*]] = fir.convert %[[Y_BOX]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.box<none>
!CHECK:  {{.*}}fir.call @_FortranAMatmul(%[[RESULT_BOX_RUNTIME]], %[[X_BOX_RUNTIME]], %[[Y_BOX_RUNTIME]], {{.*}}, {{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, i32) -> none
!CHECK:  %[[RESULT_BOX:.*]] = fir.load %[[RESULT_BOX_ADDR]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>>
!CHECK:  %[[RESULT_TMP:.*]] = fir.box_addr %[[RESULT_BOX]] : (!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>) -> !fir.heap<!fir.array<?x!fir.logical<4>>>
!CHECK:  %[[Z_COPY_FROM_RESULT:.*]] = fir.do_loop
!CHECK:    {{.*}}fir.array_fetch
!CHECK:    {{.*}}fir.array_update
!CHECK:    fir.result
!CHECK:  }
!CHECK:  fir.array_merge_store %[[Z]], %[[Z_COPY_FROM_RESULT]] to %[[Z_BOX]] : !fir.array<?x!fir.logical<4>>, !fir.array<?x!fir.logical<4>>, !fir.box<!fir.array<?x!fir.logical<4>>>
!CHECK:  fir.freemem %[[RESULT_TMP]] : !fir.heap<!fir.array<?x!fir.logical<4>>>
subroutine matmul_test2(X, Y, Z)
  logical :: X(:,:)
  logical :: Y(:)
  logical :: Z(:)
  Z = matmul(X, Y)
end subroutine


! { dg-do run }
!
! PR fortran/57798
! The call to sum used to be inlined into a loop with an uninitialized bound
!
! Original testcase by Stephan Kramer <stephan.kramer@imperial.ac.uk>

program test
  implicit none

  call sub(2, 11)

  contains

    function func(m, n)
      integer, intent(in):: m,n
      real, dimension(m, n):: func

      func = 1.0

    end function func

    subroutine sub(m, n)
      integer, intent(in):: m, n
      real, dimension(m,n):: y

      y = 1.0
      if (any(sum(y*func(m,n), dim=1) /= m)) call abort

    end subroutine sub

end program test


Module m_refpar
Integer, Parameter :: kdp = selected_real_kind(15)
public :: refpar
private :: kdp
private :: R_refpar, I_refpar, D_refpar
interface refpar
  module procedure d_refpar, r_refpar, i_refpar
end interface refpar
contains

Subroutine D_refpar (XDONT, IRNGT, NORD)
!  Ranks partially XDONT by IRNGT, up to order NORD
! __________________________________________________________
!  This routine uses a pivoting strategy such as the one of
!  finding the median based on the quicksort algorithm. It uses
!  a temporary array, where it stores the partially ranked indices
!  of the values. It iterates until it can bring the number of
!  values lower than the pivot to exactly NORD, and then uses an
!  insertion sort to rank this set, since it is supposedly small.
!  Michel Olagnon - Feb. 2000
! __________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (In) :: XDONT
      Integer, Dimension (:), Intent (Out) :: IRNGT
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Real (kind=kdp) :: XPIV, XWRK
! __________________________________________________________
!
      Integer, Dimension (SIZE(XDONT)) :: IWRKT
      Integer :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
!
      NDON = SIZE (XDONT)
!
      Do ICRS = 1, NDON
         IWRKT (ICRS) = ICRS
      End Do
      IDEB = 1
      IFIN = NDON
      Do
         If (IDEB >= IFIN) Exit
         IMIL = (IDEB+IFIN) / 2
!
!  One chooses a pivot, median of 1st, last, and middle values
!
         If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
            IWRK = IWRKT (IDEB)
            IWRKT (IDEB) = IWRKT (IMIL)
            IWRKT (IMIL) = IWRK
         End If
         If (XDONT(IWRKT(IMIL)) > XDONT(IWRKT(IFIN))) Then
            IWRK = IWRKT (IFIN)
            IWRKT (IFIN) = IWRKT (IMIL)
            IWRKT (IMIL) = IWRK
            If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
               IWRK = IWRKT (IDEB)
               IWRKT (IDEB) = IWRKT (IMIL)
               IWRKT (IMIL) = IWRK
            End If
         End If
         If ((IFIN-IDEB) < 3) Exit
         XPIV = XDONT (IWRKT(IMIL))
!
!  One exchanges values to put those > pivot in the end and
!  those <= pivot at the beginning
!
         ICRS = IDEB
         IDCR = IFIN
         ECH2: Do
            Do
               ICRS = ICRS + 1
               If (ICRS >= IDCR) Then
!
!  the first  >  pivot is IWRKT(IDCR)
!  the last   <= pivot is IWRKT(ICRS-1)
!  Note: If one arrives here on the first iteration, then
!        the pivot is the maximum of the set, the last value is equal
!        to it, and one can reduce by one the size of the set to process,
!        as if XDONT (IWRKT(IFIN)) > XPIV
!
                  Exit ECH2
!
               End If
               If (XDONT(IWRKT(ICRS)) > XPIV) Exit
            End Do
            Do
               If (XDONT(IWRKT(IDCR)) <= XPIV) Exit
               IDCR = IDCR - 1
               If (ICRS >= IDCR) Then
!
!  The last value < pivot is always IWRKT(ICRS-1)
!
                  Exit ECH2
               End If
            End Do
!
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT (ICRS)
            IWRKT (ICRS) = IWRK
         End Do ECH2
!
!  One restricts further processing to find the fractile value
!
         If (ICRS <= NORD) IDEB = ICRS
         If (ICRS > NORD) IFIN = ICRS - 1
      End Do
!
!  Now, we only need to complete ranking of the 1:NORD set
!  Assuming NORD is small, we use a simple insertion sort
!
      Do ICRS = 2, NORD
         IWRK = IWRKT (ICRS)
         XWRK = XDONT (IWRK)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK <= XDONT(IWRKT(IDCR))) Then
               IWRKT (IDCR+1) = IWRKT (IDCR)
            Else
               Exit
            End If
         End Do
         IWRKT (IDCR+1) = IWRK
      End Do
      IRNGT (1:NORD) = IWRKT (1:NORD)
      Return
!
End Subroutine D_refpar

Subroutine R_refpar (XDONT, IRNGT, NORD)
!  Ranks partially XDONT by IRNGT, up to order NORD
! __________________________________________________________
!  This routine uses a pivoting strategy such as the one of
!  finding the median based on the quicksort algorithm. It uses
!  a temporary array, where it stores the partially ranked indices
!  of the values. It iterates until it can bring the number of
!  values lower than the pivot to exactly NORD, and then uses an
!  insertion sort to rank this set, since it is supposedly small.
!  Michel Olagnon - Feb. 2000
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (In) :: XDONT
      Integer, Dimension (:), Intent (Out) :: IRNGT
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Real :: XPIV, XWRK
! __________________________________________________________
!
      Integer, Dimension (SIZE(XDONT)) :: IWRKT
      Integer :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
!
      NDON = SIZE (XDONT)
!
      Do ICRS = 1, NDON
         IWRKT (ICRS) = ICRS
      End Do
      IDEB = 1
      IFIN = NDON
      Do
         If (IDEB >= IFIN) Exit
         IMIL = (IDEB+IFIN) / 2
!
!  One chooses a pivot, median of 1st, last, and middle values
!
         If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
            IWRK = IWRKT (IDEB)
            IWRKT (IDEB) = IWRKT (IMIL)
            IWRKT (IMIL) = IWRK
         End If
         If (XDONT(IWRKT(IMIL)) > XDONT(IWRKT(IFIN))) Then
            IWRK = IWRKT (IFIN)
            IWRKT (IFIN) = IWRKT (IMIL)
            IWRKT (IMIL) = IWRK
            If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
               IWRK = IWRKT (IDEB)
               IWRKT (IDEB) = IWRKT (IMIL)
               IWRKT (IMIL) = IWRK
            End If
         End If
         If ((IFIN-IDEB) < 3) Exit
         XPIV = XDONT (IWRKT(IMIL))
!
!  One exchanges values to put those > pivot in the end and
!  those <= pivot at the beginning
!
         ICRS = IDEB
         IDCR = IFIN
         ECH2: Do
            Do
               ICRS = ICRS + 1
               If (ICRS >= IDCR) Then
!
!  the first  >  pivot is IWRKT(IDCR)
!  the last   <= pivot is IWRKT(ICRS-1)
!  Note: If one arrives here on the first iteration, then
!        the pivot is the maximum of the set, the last value is equal
!        to it, and one can reduce by one the size of the set to process,
!        as if XDONT (IWRKT(IFIN)) > XPIV
!
                  Exit ECH2
!
               End If
               If (XDONT(IWRKT(ICRS)) > XPIV) Exit
            End Do
            Do
               If (XDONT(IWRKT(IDCR)) <= XPIV) Exit
               IDCR = IDCR - 1
               If (ICRS >= IDCR) Then
!
!  The last value < pivot is always IWRKT(ICRS-1)
!
                  Exit ECH2
               End If
            End Do
!
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT (ICRS)
            IWRKT (ICRS) = IWRK
         End Do ECH2
!
!  One restricts further processing to find the fractile value
!
         If (ICRS <= NORD) IDEB = ICRS
         If (ICRS > NORD) IFIN = ICRS - 1
      End Do
!
!  Now, we only need to complete ranking of the 1:NORD set
!  Assuming NORD is small, we use a simple insertion sort
!
      Do ICRS = 2, NORD
         IWRK = IWRKT (ICRS)
         XWRK = XDONT (IWRK)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK <= XDONT(IWRKT(IDCR))) Then
               IWRKT (IDCR+1) = IWRKT (IDCR)
            Else
               Exit
            End If
         End Do
         IWRKT (IDCR+1) = IWRK
      End Do
      IRNGT (1:NORD) = IWRKT (1:NORD)
      Return
!
End Subroutine R_refpar
Subroutine I_refpar (XDONT, IRNGT, NORD)
!  Ranks partially XDONT by IRNGT, up to order NORD
! __________________________________________________________
!  This routine uses a pivoting strategy such as the one of
!  finding the median based on the quicksort algorithm. It uses
!  a temporary array, where it stores the partially ranked indices
!  of the values. It iterates until it can bring the number of
!  values lower than the pivot to exactly NORD, and then uses an
!  insertion sort to rank this set, since it is supposedly small.
!  Michel Olagnon - Feb. 2000
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (In)  :: XDONT
      Integer, Dimension (:), Intent (Out) :: IRNGT
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Integer :: XPIV, XWRK
!
      Integer, Dimension (SIZE(XDONT)) :: IWRKT
      Integer :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
!
      NDON = SIZE (XDONT)
!
      Do ICRS = 1, NDON
         IWRKT (ICRS) = ICRS
      End Do
      IDEB = 1
      IFIN = NDON
      Do
         If (IDEB >= IFIN) Exit
         IMIL = (IDEB+IFIN) / 2
!
!  One chooses a pivot, median of 1st, last, and middle values
!
         If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
            IWRK = IWRKT (IDEB)
            IWRKT (IDEB) = IWRKT (IMIL)
            IWRKT (IMIL) = IWRK
         End If
         If (XDONT(IWRKT(IMIL)) > XDONT(IWRKT(IFIN))) Then
            IWRK = IWRKT (IFIN)
            IWRKT (IFIN) = IWRKT (IMIL)
            IWRKT (IMIL) = IWRK
            If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
               IWRK = IWRKT (IDEB)
               IWRKT (IDEB) = IWRKT (IMIL)
               IWRKT (IMIL) = IWRK
            End If
         End If
         If ((IFIN-IDEB) < 3) Exit
         XPIV = XDONT (IWRKT(IMIL))
!
!  One exchanges values to put those > pivot in the end and
!  those <= pivot at the beginning
!
         ICRS = IDEB
         IDCR = IFIN
         ECH2: Do
            Do
               ICRS = ICRS + 1
               If (ICRS >= IDCR) Then
!
!  the first  >  pivot is IWRKT(IDCR)
!  the last   <= pivot is IWRKT(ICRS-1)
!  Note: If one arrives here on the first iteration, then
!        the pivot is the maximum of the set, the last value is equal
!        to it, and one can reduce by one the size of the set to process,
!        as if XDONT (IWRKT(IFIN)) > XPIV
!
                  Exit ECH2
!
               End If
               If (XDONT(IWRKT(ICRS)) > XPIV) Exit
            End Do
            Do
               If (XDONT(IWRKT(IDCR)) <= XPIV) Exit
               IDCR = IDCR - 1
               If (ICRS >= IDCR) Then
!
!  The last value < pivot is always IWRKT(ICRS-1)
!
                  Exit ECH2
               End If
            End Do
!
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT (ICRS)
            IWRKT (ICRS) = IWRK
         End Do ECH2
!
!  One restricts further processing to find the fractile value
!
         If (ICRS <= NORD) IDEB = ICRS
         If (ICRS > NORD) IFIN = ICRS - 1
      End Do
!
!  Now, we only need to complete ranking of the 1:NORD set
!  Assuming NORD is small, we use a simple insertion sort
!
      Do ICRS = 2, NORD
         IWRK = IWRKT (ICRS)
         XWRK = XDONT (IWRK)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK <= XDONT(IWRKT(IDCR))) Then
               IWRKT (IDCR+1) = IWRKT (IDCR)
            Else
               Exit
            End If
         End Do
         IWRKT (IDCR+1) = IWRK
      End Do
      IRNGT (1:NORD) = IWRKT (1:NORD)
      Return
!
End Subroutine I_refpar
end module m_refpar


program const_kind_02
integer, parameter :: int32 = 4, int64 = 8
integer(int32), parameter :: i1 = 1_int32
integer(int64), parameter :: i2 = 1_int64
integer :: i3
i3 = 1_int32
i3 = 1_int64
print *, int32, int64, i1, i2, i3
end program


MODULE Lin_Feedback_Shift_Reg
! L'Ecuyer's 1999 random number generator.
! Fortran version by Alan.Miller @ vic.cmis.csiro.au
! N.B. This version is compatible with Lahey's ELF90
! This version requires that the default integer type is of 32-bits
! http://www.ozemail.com.au/~milleraj
! http://users.bigpond.net.au/amiller/
! Latest revision - 12 January 2001

IMPLICIT NONE
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)
! These are unsigned integers in the C version
INTEGER, SAVE      :: s1 = 153587801, s2 = -759022222, s3 = 1288503317, &
                      s4 = -1718083407

CONTAINS

SUBROUTINE init_seeds(i1, i2, i3, i4)
IMPLICIT NONE

INTEGER, INTENT(IN) :: i1, i2, i3, i4

s1 = i1
s2 = i2
s3 = i3
s4 = i4
IF (IAND(s1,  -2) == 0) s1 = i1 - 1023
IF (IAND(s2,  -8) == 0) s2 = i2 - 1023
IF (IAND(s3, -16) == 0) s3 = i3 - 1023
IF (IAND(s4,-128) == 0) s4 = i4 - 1023

RETURN
END SUBROUTINE init_seeds

FUNCTION lfsr113() RESULT(random_numb)
! Generates a random number between 0 and 1.  Translated from C function in:
! Reference:
! L'Ecuyer, P. (1999) `Tables of maximally equidistributed combined LFSR
! generators', Math. of Comput., 68, 261-269.

! The cycle length is claimed to be about 2^(113) or about 10^(34).
! Actually - (2^31 - 1).(2^29 - 1).(2^28 - 1).(2^25 - 1)

IMPLICIT NONE
REAL (dp) :: random_numb

INTEGER   :: b

! N.B. ISHFT(i,j) is a bitwise (non-circular) shift operation;
!      to the left if j > 0, otherwise to the right.

b  = ISHFT( IEOR( ISHFT(s1,6), s1), -13)
s1 = IEOR( ISHFT( IAND(s1,-2), 18), b)
b  = ISHFT( IEOR( ISHFT(s2,2), s2), -27)
s2 = IEOR( ISHFT( IAND(s2,-8), 2), b)
b  = ISHFT( IEOR( ISHFT(s3,13), s3), -21)
s3 = IEOR( ISHFT( IAND(s3,-16), 7), b)
b  = ISHFT( IEOR( ISHFT(s4,3), s4), -12)
s4 = IEOR( ISHFT( IAND(s4,-128), 13), b)

! The constant below is the reciprocal of (2^32 - 1)
random_numb = IEOR( IEOR( IEOR(s1,s2), s3), s4) * 2.3283064365E-10_dp + 0.5_dp

RETURN
END FUNCTION lfsr113

END MODULE Lin_Feedback_Shift_Reg

PROGRAM t_lfsr113
USE Lin_Feedback_Shift_Reg
IMPLICIT NONE
INTEGER              :: i1, i2, i3, i4, i, j, k, l, m, freq(0:15,0:15,0:15,0:15)
INTEGER, ALLOCATABLE :: seed(:)
REAL (dp)            :: x, chi_sq, expctd, deg_freedom, stdev, lower, upper

WRITE(*, *)'Enter 4 integers as seeds: '
READ(*, *) i1, i2, i3, i4
CALL init_seeds(i1, i2, i3, i4)

x = lfsr113()
i = 16*x
x = lfsr113()
j = 16*x
x = lfsr113()
k = 16*x
freq = 0
DO m= 1, 10000000
  x = lfsr113()
  l = 16*x
  freq(i,j,k,l) = freq(i,j,k,l) + 1
  i = j
  j = k
  k = l
END DO

expctd = REAL( SUM(freq) ) / (16. * 16. * 16. * 16.)
chi_sq = 0.0_dp
DO i = 0, 15
  DO j = 0, 15
    DO k = 0, 15
      chi_sq = chi_sq + SUM( (REAL(freq(i,j,k,:)) - expctd)**2 ) / expctd
    END DO
  END DO
END DO

deg_freedom = (16. * 16. * 16. * 16.) - 1.
WRITE(*, '(a, f10.1, a, f6.0, a)') ' Chi-squared = ', chi_sq, ' with ',  &
                                  deg_freedom, ' deg. of freedom'

! Now repeat the exercise with the compiler's random number generator.

CALL RANDOM_SEED(size=k)
ALLOCATE( seed(k) )
IF (i1 /= 0) THEN
  seed(1) = i1
ELSE
  seed(1) = 1234567
END IF
IF (k >= 2) seed(2) = i2
IF (k >= 3) seed(3) = i3
DO i = 4, k
  seed(i) = seed(i-3)
END DO
CALL RANDOM_SEED(put=seed)

CALL RANDOM_NUMBER(x)
i = 16*x
CALL RANDOM_NUMBER(x)
j = 16*x
CALL RANDOM_NUMBER(x)
k = 16*x
freq = 0
DO m= 1, 10000000
  CALL RANDOM_NUMBER(x)
  l = 16*x
  freq(i,j,k,l) = freq(i,j,k,l) + 1
  i = j
  j = k
  k = l
END DO

expctd = REAL( SUM(freq) ) / (16. * 16. * 16. * 16.)
chi_sq = 0.0_dp
DO i = 0, 15
  DO j = 0, 15
    DO k = 0, 15
      chi_sq = chi_sq + SUM( (REAL(freq(i,j,k,:)) - expctd)**2 ) / expctd
    END DO
  END DO
END DO

WRITE(*, '(a, f10.1, a, f6.0, a)') ' Chi-squared = ', chi_sq, ' with ',  &
                                  deg_freedom, ' deg. of freedom'

! Calculate rough limits for chi-squared based upon a normal approximation.
stdev = SQRT(2. * deg_freedom)
upper = deg_freedom + 2.*stdev
lower = deg_freedom - 2.*stdev
WRITE(*, '(a, f8.1, a, f8.1)') ' Approx. 95% limits for chi-squared: ',  &
            lower, ' - ', upper

STOP
END PROGRAM t_lfsr113


Module stress_Mod
  ! Module for building stiffness tensors, tensor transformations, and converting different definitions of stress

Contains

  Pure Function StiffFunc(NTENS, E1, E2, E3, G12, G13, G23, v12, v13, v23, d1, d2, d3) result(Stiff)
    ! Constructs the damaged orthotropic stiffness tensor based on the calculated damage state variables

    ! Input
    Double Precision, intent(IN) :: E1,E2,E3,G12,G13,G23,v12,v23,v13,d1,d2,d3
    Integer, intent(IN) :: NTENS

    ! Output
    Double Precision :: Stiff(NTENS,NTENS)

    ! Locals
    Double Precision :: v21, v31, v32, delta
    Double Precision, parameter :: zero=0.d0, one=1.d0, two=2.d0
    ! -------------------------------------------------------------------- !

    v21 = v12*E2/E1
    If (NTENS > 4) Then
       v31 = v13*E3/E1
       v32 = v23*E3/E2
    Else
       v31 = zero
       v32 = zero
    End If

    delta = one/(one - v12*v21*(one-d1)*(one-d2) - v23*v32*(one-d2)*(one-d3) - v31*v13*(one-d1)*(one-d3) - two*v12*v23*v31*(one-d1)*(one-d2)*(one-d3))
    Stiff = zero

    Stiff(1,1) = delta*(one-d1)*(one - v23*v32*(one-d2)*(one-d3))*E1
    Stiff(2,2) = delta*(one-d2)*(one - v13*v31*(one-d1)*(one-d3))*E2

    Stiff(1,2) = delta*(one-d1)*(one-d2)*(v12 + v32*v13*(one-d3))*E2
    Stiff(2,1) = Stiff(1,2)

    If (NTENS == 3) Then  ! Shell element in Abaqus/Standard
      Stiff(3,3) = (one-d1)*(one-d2)*G12
    Else
      Stiff(3,3) = delta*(one-d3)*(one - v12*v21*(one-d1)*(one-d2))*E3
      Stiff(4,4) = (one-d1)*(one-d2)*G12
    End If

    If (NTENS > 4) Then ! Solid element
      Stiff(1,3) = delta*(one-d1)*(one-d3)*(v13+v12*v23*(one-d2))*E3
      Stiff(3,1) = Stiff(1,3)
      Stiff(2,3) = delta*(one-d2)*(one-d3)*(v23+v21*v13*(one-d1))*E3
      Stiff(3,2) = Stiff(2,3)
      Stiff(5,5) = (one-d2)*(one-d3)*G23
      Stiff(6,6) = (one-d1)*(one-d3)*G13
    End If

    Return
  End Function StiffFunc

  Subroutine StiffFuncNL(m, ndir, nshr, d1, d2, d3, eps, stiff, sr)
    ! Constructs the damaged orthotropic stiffness tensor accounting for damage state variables and recoverable
    ! pre-peak nonlinearities including Schapery and elastic fiber nonlinearity

    Use matProp_Mod
    Use schapery_mod

    ! Arguments
    Type(matProps), intent(IN) :: m
    Integer, intent(IN) :: ndir, nshr
    Double Precision, intent(IN) :: d1, d2, d3                       ! Damage state variables
    Double Precision, intent(IN) :: eps(ndir,ndir)                   ! Green-Lagrange strain tensor
    Double Precision, intent(OUT) :: stiff(ndir+nshr,ndir+nshr)      ! Stiffness tensor
    Double Precision :: sr                                           ! Shapery state variable (no intent is specified so that zero can be used when schapery is N/A)

    ! Locals
    Double Precision :: E1
    Double Precision, parameter :: zero=0.d0, one=1.d0, two=2.d0
    ! -------------------------------------------------------------------- !

    If (m%Schapery) Then
      sr = Schapery_damage(m, eps, sr)
    Else
      sr = zero
    End If

    ! Elastic fiber nonlinearity
    E1 = m%E1*(1+m%cl*eps(1,1))

    ! Update stiffness matrix
    stiff = StiffFunc(ndir+nshr, E1, m%E2*Schapery_reduction(sr, m%es), m%E3, m%G12*Schapery_reduction(sr, m%gs), m%G13, m%G23, m%v12, m%v13, m%v23, d1, d2, d3)

    Return
  End Subroutine StiffFuncNL

  Function StiffRot(C, NTENS, theta) result(StiffOut)
    ! Rotates the stiffness matrix by the specified angle (radians)

    Use forlog_Mod

    ! Input
    Double Precision, intent(IN) :: C(NTENS,NTENS), theta
    Integer, intent(IN) :: NTENS

    ! Output
    Double Precision :: StiffOut(NTENS,NTENS)

    ! Locals
    Double Precision :: m, n
    Double Precision :: zero, one, two, four
    Parameter (zero=0.d0, one=1.d0, two=2.d0, four=4.d0)
    ! -------------------------------------------------------------------- !

    m = cos(theta)
    n = sin(theta)

    StiffOut = 0

    ! Depends on element type
    If (NTENS > 4) Then
      StiffOut(1,1) = m**four*C(1,1) + 2*m**two*n**two*(C(1,2) + 2*C(4,4)) + n**four*C(2,2)
      StiffOut(1,2) = n**two*m**two*(C(1,1) + C(2,2) - four*C(4,4)) + (n**four + m**four)*C(1,2)
      StiffOut(1,3) = m**two*C(1,3) + n**two*C(2,3)
      StiffOut(1,4) = n*m*(m**two*(C(1,1) - C(1,2) - two*C(4,4)) + n**two*(C(1,2) - C(2,2) + two*C(4,4)))
      StiffOut(2,1) = StiffOut(1,2)
      StiffOut(2,2) = n**four*C(1,1) + 2*m**two*n**two*(C(1,2) + 2*C(4,4)) + m**four*C(2,2)
      StiffOut(2,3) = n**two*C(1,3) + m**two*C(2,3)
      StiffOut(2,4) = n*m*(n**two*(C(1,1) - C(1,2) - two*C(4,4)) + m**two*(C(1,2) - C(2,2) + two*C(4,4)))
      StiffOut(3,1) = StiffOut(1,3)
      StiffOut(3,2) = StiffOut(2,3)
      StiffOut(3,3) = C(3,3)
      StiffOut(3,4) = m*n*(C(1,3) - C(2,3))
      StiffOut(4,1) = StiffOut(1,4)
      StiffOut(4,2) = StiffOut(2,4)
      StiffOut(4,3) = StiffOut(3,4)
      StiffOut(4,4) = n**two*m**two*(C(1,1) - two*C(1,2) + C(2,2)) + C(4,4)*(n**two - m**two)**two
      StiffOut(5,5) = m**two*C(5,5) + n**two*C(6,6)
      StiffOut(5,6) = m*n*(C(6,6) - C(5,5))
      StiffOut(6,5) = StiffOut(5,6)
      StiffOut(6,6) = n**two*C(5,5) + m**two*C(6,6)

    Else
      Call log%error("Plane stress stiffness transformation is not implemented")

    End If

    Return
  End Function StiffRot

  Pure Function convertToCauchy(stress, F) result(Cauchy)
    ! Converts the stress to Cauchy stress

    Use matrixAlgUtil_Mod

    ! Input
    Double Precision, intent(IN) :: stress(3,3)
    Double Precision, intent(IN) :: F(3,3)            ! Deformation gradient

    ! Output
    Double Precision :: Cauchy(3,3)
    ! -------------------------------------------------------------------- !

    Cauchy = MATMUL(F, MATMUL(stress, TRANSPOSE(F)))/MDet(F)

    Return
  End Function convertToCauchy

  Pure Function Hooke(C, strain, nshr) result(stress)
    ! Calculates the energy conjugate stress based on the input strain and stiffness tensor

    Use matrixAlgUtil_Mod

    ! Input
    Double Precision, intent(IN) :: C(3+nshr,3+nshr)         ! Stiffness
    Double Precision, intent(IN) :: strain(3,3)
    Integer, intent(IN) :: nshr

    ! Output
    Double Precision :: stress(3,3)

    ! Locals
    Double Precision :: strainVec(3+nshr), stressVec(3+nshr)
    Double Precision, parameter :: zero=0.d0, two=2.d0
    ! -------------------------------------------------------------------- !

    stress = zero

    ! Convert strain to vector format, engineering shear strain
    strainVec = Matrix2Vec(strain, nshr)
    Do I=4,3+nshr; strainVec(I) = two*strainVec(I); End Do

    ! Compute stress vector
    stressVec = MATMUL(C,strainVec)

    ! Convert back to matrix format
    stress = Vec2Matrix(stressVec)

    Return
  End Function Hooke

End Module stress_Mod


      REAL*8 a,ci,cs,gs,oi,ca,vmx,rh,kg,ko,kc,tau,rd,ga,t,p,j

      t = 14.0d0
      kg = 1.0d0
      rh = 60.0d0
      vmx = 23.0e-6

      p =
      ga =

      tk = 273.0d0 + t
      kc = exp(35.8d0 - 80.5d0/(0.00831d0*tk))
      ko = exp(9.6d0 - 14.51d0/(0.00831d0*tk))*1000.0d0
      tau = exp(-3.949d0 + 28.99d0/(0.00831d0*tk))

      CALL ASSVMAX(a,ci,cs,gs,oi,ca,vmx,rh,kg,ko,kc,tau,rd,ga,t,p)

      CALL ASSJ(a,ci,cs,gs,oi,ca,rh,kg,tau,rd,ga,t,p,j)

      stop
      end

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE ASSVMAX                          *
*                          ******************                          *
*                                                                      *
* ASSVMAX computes the assimilation rate by forming a cubic equation   *
* from the equations defining assimilation rate, stomatal conductance, *
* CO2 partial pressure (assimilation diffusion equaiton) and the       *
* carboxylation rate. The cubic equation is solved and the largest     *
* real root is assumed to be the assimilation rate. The variables here *
* correspond to the Doly paper, in the main program they are such that *
*        po,pa,vmax,g0,g1,rh,ko,kc,kg,tau,rd                           *
*     = oi,ca,vmx(i),c1,c2,rh,ko,kc,kg,tau,rd.                         *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE ASSVMAX(a,ci,cs,gs,oi,ca,vmx,rh,kg,ko,kc,tau,rd,ga,t,p)
*----------------------------------------------------------------------*
      REAL*8 a,ci,gs,oi,ca,vmx,rh,ko,kc,tau,rd,fa0,faf,gam,step
      REAL*8 p,ga,x,y,dv,t,a0,cs,af,fa,kg,ax,bx,cx,gsmin
      INTEGER i

      gsmin = 0.005d0

      x = -1.5d0 + 0.2d0*t
      if (x.LT.0.25d0) x = 0.25d0
      y = 1.5d0

      dv = 0.6108d0*exp(17.269d0*t/(237.3d0 + t))*(1.0d0 -
     &rh/100.0d0)

      if (5.gt.30) then
      do i=0,200
      a = real(i)/10.0d0
      cs = ca - a*1.0e-6*p/ga
      gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
      ci = cs - a*1.0e-6*p/gs
      gam = 1.0d0 - 0.5d0*oi/tau/ci
      fa0 = a - (gam*vmx*ci/(ci + kc*(1.0d0 + oi/ko)) -
     &rd)*1.0e6
      print'(7f10.3)',a,fa0,cs,gs,ci,gam,(x*a/(1.0d0 + dv/y)/(cs*10.0d0
     & - 1.54d0*t))
      enddo
      endif

      step = 1.0d0
      a = 0.0d0
      cs = ca - a*1.0e-6*p/ga
      gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
      ci = cs - a*1.0e-6*p/gs
      gam = 1.0d0 - 0.5d0*oi/tau/ci
      fa0 = a - (gam*vmx*ci/(ci + kc*(1.0d0 + oi/ko)) -
     &rd)*1.0e6

      a0 = a

50    CONTINUE
        a = a + step
        cs = ca - a*1.0e-6*p/ga
        gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
        ci = cs - a*1.0e-6*p/gs
        gam = 1.0d0 - 0.5d0*oi/tau/ci
        faf = a - (gam*vmx*ci/(ci + kc*(1.0d0 + oi/ko)) -
     &rd)*1.0e6
      IF (faf.LT.0.0d0) THEN
        fa0 = faf
        a0 = a
        GOTO 50
      ENDIF
      af = a

      IF (af.GT.100d0) THEN
        a = 0.0d0
        cs = ca - a*1.0e-6*p/ga
        gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
        ci = cs - a*1.0e-6*p/gs
        gam = 1.0d0 - 0.5d0*oi/tau/ci
      ELSE
        a = (a0 + af)/2.0d0
        cs = ca - a*1.0e-6*p/ga
        gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
        ci = cs - a*1.0e-6*p/gs
        gam = 1.0d0 - 0.5d0*oi/tau/ci
        fa = a - (gam*vmx*ci/(ci + kc*(1.0d0 + oi/ko)) -
     &rd)*1.0e6

        bx = ((a+a0)*(faf-fa)/(af-a)-(af+a)*(fa-fa0)/(a-a0))/(a0-af)
        ax = (faf-fa-bx*(af-a))/(af**2-a**2)
        cx = fa-bx*a-ax*a**2

        IF (abs(ax).GT.0.0d0) THEN
          IF (bx**2-4.0d0*ax*cx.GT.0.0d0) THEN
            a = (-bx+(bx**2-4.0d0*ax*cx)**0.5)/(2.0d0*ax)
        IF (a.GT.af)  a = (-bx-(bx**2-4.0d0*ax*cx)**0.5)/(2.0d0*ax)
          ELSE
            a = 0.0d0
          ENDIF
        ELSE
          IF (abs(bx).GT.0.0d0) THEN
            a =-cx/bx
          ELSE
            a = 0.0d0
          ENDIF
        ENDIF

      ENDIF

        cs = ca - a*1.0e-6*p/ga
        gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
        ci = cs - a*1.0e-6*p/gs
        gam = 1.0d0 - 0.5d0*oi/tau/ci
*      print'(6f10.3)',a,fa0,cs,gs,ci,gam
*      print*

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE ASSJ                             *
*                          ***************                             *
*                                                                      *
* ASSVMAX computes the assimilation rate by forming a cubic equation   *
* from the equations defining assimilation rate, stomatal conductance, *
* CO2 partial pressure (assimilation diffusion equaiton) and the       *
* carboxylation rate. The cubic equation is solved and the largest     *
* real root is assumed to be the assimilation rate. The variables here *
* correspond to the Doly paper, in the main program they are such that *
*        po,pa,vmax,g0,g1,rh,ko,kc,kg,tau,rd                           *
*     = oi,ca,vmx(i),c1,c2,rh,ko,kc,kg,tau,rd.                         *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE ASSJ(a,ci,cs,gs,oi,ca,rh,kg,tau,rd,ga,t,p,j)
*----------------------------------------------------------------------*
      REAL*8 a,ci,gs,oi,ca,rh,tau,rd,j,gam,fa0,faf,a0,af,step
      REAL*8 p,ga,x,y,dv,t,cs,fa,kg
      REAL*8 ax,bx,cx,gsmin

      gsmin = 0.005d0

      x = -1.5d0 + 0.2d0*t
      if (x.LT.0.25d0) x = 0.25d0
      y = 1.5

      dv = 0.6108d0*exp(17.269d0*t/(237.3d0 + t))*(1.0d0 -
     &rh/100.0d0)

      step = 1.0d0
      a = 0.0d0
      cs = ca - a*1.0e-6*p/ga
      gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
      ci = cs - a*1.0e-6*p/gs
      gam = 1.0d0 - 0.5d0*oi/tau/ci
      fa0 = a - (gam*j*ci/4.0d0/(ci + oi/tau) -
     &rd)*1.0e6

      a0 = a

50    CONTINUE
        a = a + step
        cs = ca - a*1.0e-6*p/ga
        gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
        ci = cs - a*1.0e-6*p/gs
        gam = 1.0d0 - 0.5d0*oi/tau/ci
        faf = a - (gam*j*ci/4.0d0/(ci + oi/tau) -
     &rd)*1.0e6
      IF (faf.LT.0.0d0) THEN
        fa0 = faf
        a0 = a
        GOTO 50
      ENDIF
      af = a

      IF (af.GT.100d0) THEN
        a = 0.0d0
        cs = ca - a*1.0e-6*p/ga
        gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
        ci = cs - a*1.0e-6*p/gs
        gam = 1.0d0 - 0.5d0*oi/tau/ci
      ELSE

        a = (a0 + af)/2.0d0
        cs = ca - a*1.0e-6*p/ga
        gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
        ci = cs - a*1.0e-6*p/gs
        gam = 1.0d0 - 0.5d0*oi/tau/ci
        fa = a - (gam*j*ci/4.0d0/(ci + oi/tau) -
     &rd)*1.0e6

        bx = ((a+a0)*(faf-fa)/(af-a)-(af+a)*(fa-fa0)/(a-a0))/(a0-af)
        ax = (faf-fa-bx*(af-a))/(af**2-a**2)
        cx = fa-bx*a-ax*a**2

        IF (abs(ax).GT.0.0d0) THEN
          IF (bx**2-4.0d0*ax*cx.GT.0.0d0) THEN
            a = (-bx+(bx**2-4.0d0*ax*cx)**0.5)/(2.0d0*ax)
        IF (a.GT.af)  a = (-bx-(bx**2-4.0d0*ax*cx)**0.5)/(2.0d0*ax)
          ELSE
            a = 0.0d0
          ENDIF
        ELSE
          IF (abs(bx).GT.0.0d0) THEN
            a =-cx/bx
          ELSE
            a = 0.0d0
          ENDIF
        ENDIF

      ENDIF

        cs = ca - a*1.0e-6*p/ga
        gs = gsmin + (x*a/(1.0d0 + dv/y)/(cs*10.0d0 -
     &1.54d0*t))*kg
        ci = cs - a*1.0e-6*p/gs
        gam = 1.0d0 - 0.5d0*oi/tau/ci

      RETURN
      END


! =============================================================================
!                           Module to split ellipses
! =============================================================================
module parcel_split
    use options, only : verbose
    use constants, only : pi, three, f12, f14, f34
    use parameters, only : vmax
    use parcel_container, only : parcel_container_type, n_parcels
    use parcel_bc, only : apply_reflective_bc
    use parcel_ellipse, only : get_eigenvalue      &
                             , get_eigenvector     &
                             , get_B22             &
                             , get_aspect_ratio
    use timer, only : start_timer, stop_timer
    use omp_lib
    implicit none

    integer :: split_timer

    contains

        ! Split large parcels (volumes larger than vmax) or
        ! parcels with aspect ratios larger than the threshold.
        ! @param[inout] parcels
        ! @param[in] threshold is the largest allowed aspect ratio
        subroutine split_ellipses(parcels, threshold)
            type(parcel_container_type), intent(inout) :: parcels
            double precision,            intent(in)    :: threshold
            double precision                           :: B11
            double precision                           :: B12
            double precision                           :: B22
            double precision                           :: a2, lam, V
            double precision                           :: evec(2)
            double precision                           :: h
            integer                                    :: last_index
            integer                                    :: n, n_thread_loc

            call start_timer(split_timer)

            last_index = n_parcels

            !$omp parallel default(shared)
            !$omp do private(n, B11, B12, B22, a2, lam, V, evec, h, n_thread_loc)
            do n = 1, last_index
                B11 = parcels%B(1, n)
                B12 = parcels%B(2, n)
                V = parcels%volume(n)
                B22 = get_B22(B11, B12, V)

                a2 = get_eigenvalue(B11, B12, B22)

                ! a/b
                lam = get_aspect_ratio(a2, V)

                if (lam <= threshold .and. V <= vmax) then
                    cycle
                endif

                !
                ! this ellipse is split, i.e., add a new parcel
                !

                evec = get_eigenvector(a2, B11, B12, B22)

                parcels%B(1, n) = B11 - f34 * a2 * evec(1) ** 2
                parcels%B(2, n) = B12 - f34 * a2 * (evec(1) * evec(2))

                h = f14 * dsqrt(three * a2)
                parcels%volume(n) = f12 * V

                !$omp critical
                n_thread_loc = n_parcels + 1

                ! we only need to add one new parcel
                n_parcels = n_parcels + 1
                !$omp end critical

                parcels%B(:, n_thread_loc) = parcels%B(:, n)

                parcels%vorticity(n_thread_loc) = parcels%vorticity(n)
                parcels%volume(n_thread_loc) = parcels%volume(n)
                parcels%buoyancy(n_thread_loc) = parcels%buoyancy(n)
#ifndef ENABLE_DRY_MODE
                parcels%humidity(n_thread_loc) = parcels%humidity(n)
#endif
                parcels%position(:, n_thread_loc) = parcels%position(:, n) - h * evec
                parcels%position(:, n) = parcels%position(:, n) + h * evec

                ! child parcels need to be reflected into domain, if their center
                ! is inside the halo region
                call apply_reflective_bc(parcels%position(:, n_thread_loc), &
                                         parcels%B(:, n_thread_loc))

                call apply_reflective_bc(parcels%position(:, n), parcels%B(:, n))

            enddo
            !$omp end do
            !$omp end parallel

#ifdef ENABLE_VERBOSE
            if (verbose) then
                print "(a36, i0, a3, i0)", &
                      "no. parcels before and after split: ", last_index, "...", n_parcels
            endif
#endif

            call stop_timer(split_timer)

        end subroutine split_ellipses

end module parcel_split


SUBROUTINE SS_2RectLinear(eNum)
   USE PrecTypes
   USE GlobalData
   USE Gauss
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   SS_2RectLinear
   ! PARENT: StressStrain
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Calculate strain, stress components, and von Mises stress for a
   !         rectanglular linear element.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER, INTENT(IN) :: eNum ! element number
   INTEGER :: i,j,k,l
   REAL(dp) :: dudx, dudy      ! displacement gradients
   REAL(dp) :: dvdx, dvdy      ! displacement gradients
   REAL(dp) :: u1,v1           ! displacement components of point 1 of the quadrilateral element
   REAL(dp) :: u2,v2           ! displacement components of point 2 of the quadrilateral element
   REAL(dp) :: u3,v3           ! displacement components of point 3 of the quadrilateral element
   REAL(dp) :: u4,v4           ! displacement components of point 4 of the quadrilateral element
   REAL(dp) :: N1, N2, N3, N4  ! shape functions
   REAL(dp) :: eta, xi, eta4, xi4
   REAL(dp) :: DN1Dxi, DN1Deta, DN2Dxi, DN2Deta, DN3Dxi, DN3Deta, DN4Dxi, DN4Deta
   REAL(dp) :: DxDxi, DxDeta, DyDxi, DyDeta
   REAL(dp) :: invJ11, invJ12, invJ21, invJ22
   REAL(dp) :: DN1Dx, DN1Dy, DN2Dx, DN2Dy, DN3Dx, DN3Dy, DN4Dx, DN4Dy
   REAL(dp) :: det, Delta

   REAL(dp) :: coef, coef2
   REAL(dp) :: Yng, Pssn, a      ! Young's modulus, Poisson's ratio, linear thermal expansion coefficient of this element
   INTEGER  :: p1, p2, p3, p4    ! Node numbers defining the element
   REAL(dp) :: x1, y1, x2, y2, x3, y3, x4, y4, xp, yp, Tp
   REAL(dp) :: ex, ey, exy       ! Direct strains in x and y directions and engineering shear strain
    REAL(dp) :: sx, sy, sxy, sz  ! Direct stresses in x and y directions and shear stress

   Yng  = E( emtype(eNum) )      ! Young's modulus
   Pssn = v( emtype(eNum) )      ! Poisson's ratio
   IF (pcode == 3) a = alpha( emtype(eNum) )
   p1 = elm(eNum,1)
   p2 = elm(eNum,2)
   p3 = elm(eNum,3)
   p4 = elm(eNum,4)

   ! The coordinates of node 1 of the triangular element
   x1 = x( p1 )
   y1 = y( p1 )

   ! The coordinates of node 2 of the triangular element
   x2 = x( p2 )
   y2 = y( p2 )

   ! The coordinates of node 3 of the triangular element
   x3 = x( p3 )
   y3 = y( p3 )

   ! The coordinates of node 4 of the triangular element
   x4 = x( p4 )
   y4 = y( p4 )

   ! Displacement components of each vertex point of the quadrilateral element
   u1 = u(p1,1)
   v1 = u(p1,2)
   u2 = u(p2,1)
   v2 = u(p2,2)
   u3 = u(p3,1)
   v3 = u(p3,2)
   u4 = u(p4,1)
   v4 = u(p4,2)

   DO k=1,etype(eNum)

      IF (k==1) THEN
         xi  = -1.0_dp
         eta = -1.0_dp
      ELSE IF (k==2) THEN
         xi  =  1.0_dp
         eta = -1.0_dp
      ELSE IF (k==3) THEN
         xi  =  1.0_dp
         eta =  1.0_dp
      ELSE IF (k==4) THEN
         xi  = -1.0_dp
         eta =  1.0_dp
      END IF

      xi4  = 0.25_dp * xi     ! xi/4
      eta4 = 0.25_dp * eta    ! eta/4

      DN1Dxi  = -0.25_dp + eta4
      DN1Deta = -0.25_dp + xi4
      DN2Dxi  =  0.25_dp - eta4
      DN2Deta = -0.25_dp - xi4
      DN3Dxi  =  0.25_dp + eta4
      DN3Deta =  0.25_dp + xi4
      DN4Dxi  = -0.25_dp - eta4
      DN4Deta =  0.25_dp - xi4

      DxDxi  = DN1Dxi  * x1 + DN2Dxi  * x2 + DN3Dxi  * x3 + DN4Dxi  * x4
      DxDeta = DN1Deta * x1 + DN2Deta * x2 + DN3Deta * x3 + DN4Deta * x4
      DyDxi  = DN1Dxi  * y1 + DN2Dxi  * y2 + DN3Dxi  * y3 + DN4Dxi  * y4
      DyDeta = DN1Deta * y1 + DN2Deta * y2 + DN3Deta * y3 + DN4Deta * y4

      det = DxDxi * DyDeta - DyDxi * DxDeta
      Delta = ABS(det)

      invJ11 =  DyDeta
      invJ12 = -DyDxi
      invJ21 = -DxDeta
      invJ22 =  DxDxi
      DN1Dx = (invJ11 * DN1Dxi + invJ12 * DN1Deta)/det       !   ∂N1/∂x
      DN1Dy = (invJ21 * DN1Dxi + invJ22 * DN1Deta)/det       !   ∂N1/∂y
      DN2Dx = (invJ11 * DN2Dxi + invJ12 * DN2Deta)/det       !   ∂N2/∂x
      DN2Dy = (invJ21 * DN2Dxi + invJ22 * DN2Deta)/det       !   ∂N2/∂y
      DN3Dx = (invJ11 * DN3Dxi + invJ12 * DN3Deta)/det       !   ∂N3/∂x
      DN3Dy = (invJ21 * DN3Dxi + invJ22 * DN3Deta)/det       !   ∂N3/∂y
      DN4Dx = (invJ11 * DN4Dxi + invJ12 * DN4Deta)/det       !   ∂N4/∂x
      DN4Dy = (invJ21 * DN4Dxi + invJ22 * DN4Deta)/det       !   ∂N4/∂y

      dudx = DN1Dx * u1 + DN2Dx * u2 + DN3Dx * u3 + DN4Dx * u4
      dudy = DN1Dy * u1 + DN2Dy * u2 + DN3Dy * u3 + DN4Dy * u4
      dvdx = DN1Dx * v1 + DN2Dx * v2 + DN3Dx * v3 + DN4Dx * v4
      dvdy = DN1Dy * v1 + DN2Dy * v2 + DN3Dy * v3 + DN4Dy * v4

      ! strain components
      strain(eNum,k,1) = dudx
      strain(eNum,k,2) = dvdy
      strain(eNum,k,3) = dudy + dvdx

      ex  = strain(eNum,k,1)
      ey  = strain(eNum,k,2)
      exy = strain(eNum,k,3)

      ! stress components
      coef = Yng / (1.0_dp - 2.0_dp*Pssn)  !  <=  E / (1-2v)
      coef2 = coef / (1.0_dp+Pssn)         !  <=  E / ((1-2v)*(1+v))
      stress(eNum,k,1) = coef2 * ( (1.0_dp-Pssn)*ex + Pssn*ey )
      stress(eNum,k,2) = coef2 * ( Pssn*ex + (1.0_dp-Pssn)*ey )
      stress(eNum,k,3) = 0.5_dp * Yng / (1.0_dp+Pssn) * exy
      ! Ou-of-plane stress σz is also calculated for plane strain case.
      IF (plane == 1) THEN
         stress(eNum,k,4) = coef2*Pssn*(ex+ey)
      END IF

      ! -------------------------------------------------
      ! Effect of the thermal strain is also added for linear thermoelastic problems
      IF (pcode == 3) THEN
         N1 = 0.25_dp * (1.0_dp - xi) * (1.0_dp - eta)
         N2 = 0.25_dp * (1.0_dp + xi) * (1.0_dp - eta)
         N3 = 0.25_dp * (1.0_dp + xi) * (1.0_dp + eta)
         N4 = 0.25_dp * (1.0_dp - xi) * (1.0_dp + eta)
         Tp = N1 * T(elm(eNum,1)) + N2 * T(elm(eNum,2)) &
            + N3 * T(elm(eNum,3)) + N4 * T(elm(eNum,4))

         stress(eNum,k,1) = stress(eNum,k,1) - a*coef*Tp
         stress(eNum,k,2) = stress(eNum,k,2) - a*coef*Tp

         ! For plane strain case, the effect of the thermal strain to the out-of-plane stress is calculated.
         IF (plane == 1) THEN
            stress(eNum,k,4) = stress(eNum,k,4) - a*coef*Tp
         END IF
      END IF

      ! -------------------------------------------------
      ! Out-of-plane strain εz is also calculated for plane stress case.
      IF (plane == 2) THEN

         !　εz = - v/(1-2v) *（εx＋εy）
         coef = Pssn/(1.0_dp - 2.0_dp*Pssn)
         strain(eNum,k,4) = - coef * (strain(eNum,k,1) + strain(eNum,k,2))

         IF (pcode == 3) THEN
            !　εz = - v/(1-2v) *（εx＋εy）+ (1+v)/(1-2v)*α*T
            strain(eNum,k,4) = strain(eNum,k,4) + (1.0_dp+Pssn)/(1-2.0_dp*Pssn)*a*Tp
         END IF

      END IF

      ! von Mises stress
      ! Plane strain case
      IF (plane==1) THEN
         sx  = stress(eNum,k,1)
         sy  = stress(eNum,k,2)
         sxy = stress(eNum,k,3)
         sz  = stress(eNum,k,4)
         Mises(eNum,k) = sx*sx+sy*sy+sz*sz+3.0_dp*sxy*sxy-sx*sy-sx*sz-sy*sz
         Mises(eNum,k) = sqrt( Mises(eNum,k) )
      ! Plane stress case
      ELSE IF (plane==2) THEN
         sx  = stress(eNum,k,1)
         sy  = stress(eNum,k,2)
         sxy = stress(eNum,k,3)
         Mises(eNum,k) = sx*sx+sy*sy+3.0_dp*sxy*sxy-sx*sy
         Mises(eNum,k) = sqrt( Mises(eNum,k) )
      END IF

   END DO

   RETURN
END SUBROUTINE SS_2RectLinear


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE PRINC3(SK1, SK2, SK3, SK4, SK5, SK6, EV, INFO)

      REAL EV(3)
      REAL I1, I2, I3
      INTEGER INFO

      PARAMETER (THIRD = 0.33333 33333 33333 33333 33333)
      SQRT3  = SQRT(3.0)

      INFO = 0

C Find principal trial stresses and directions -

      I1 = ( SK1 + SK2 + SK3 )
      I2 = ( (SK1-SK2)**2 + (SK1-SK3)**2 + (SK2-SK3)**2 ) / 6.0
     *     + SK4**2 + SK5**2 + SK6**2

      S1 = ( (SK1 - SK2) + (SK1 - SK3) ) * THIRD
      S2 = (-(SK1 - SK2) + (SK2 - SK3) ) * THIRD
      S3 = (-(SK1 - SK3) - (SK2 - SK3) ) * THIRD

      I3 = S1 * S2 * S3 + 2.*SK4 * SK5 * SK6
     *     - S1 * SK5**2 - S2 *  SK6**2
     *     - S3 * SK4**2

C     Calculate constants for Malvern Method  (p92)

C .... This sign trick does not work on Ultrix (and others?) with IEEE
C      since IEEE has a signed 0...........
CC      FI2 = I2 + (SIGN (0.5, I2) + SIGN (0.5, -I2))

      IF (I2 .EQ. 0.0) THEN
         FI2 = 1.0
      ELSE
         FI2 = I2
      END IF

      COS3AL = SQRT3 * 1.5 * I3 / FI2 / SQRT(FI2)
      COS3AL = SIGN( MIN( 1.0, ABS(COS3AL) ),COS3AL )

C     ... TRIG FUNCTION USED

      CALPHA = COS( ACOS(COS3AL) / 3.0)
      SALPHA = SQRT(1.0 - CALPHA**2)

      T  = SQRT3 * SQRT(I2)
      P1 = (I1 + T *  2. * CALPHA             ) * THIRD
      P2 = (I1 - T * (CALPHA + SALPHA * SQRT3)) * THIRD
      P3 = (I1 - T * (CALPHA - SALPHA * SQRT3)) * THIRD

C ... Sort Into Correct Position (ev1 < ev2 < ev3)

      EV(1) = MIN(P1, P2, P3)
      EV(3) = MAX(P1, P2, P3)

C ... This is bad from a round-off perspective, but we don't use the
C     value in algebra.  Be warned if use where you need an accurate
C     ev(2).....

      EV(2) = P1 + P2 + P3 - EV(1) - EV(3)

      RETURN
      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_wann_lapw_int_plot

c***************************************************************
c         plot wannierfunction in interstitial
c         Frank Freimuth, November 2006
c***************************************************************

      CONTAINS
      SUBROUTINE wann_lapw_int_plot(point,bmat,unigrid,wannint,
     <                              xdnout)
      use m_constants
      implicit none
      real,intent(in)::point(3)
      real,intent(in)::bmat(3,3)
      integer,intent(in)::unigrid(4)
      complex,intent(in)::wannint(-unigrid(4):unigrid(4),
     ,                            -unigrid(4):unigrid(4),
     ,                            -unigrid(4):unigrid(4))
      complex,intent(out)::xdnout

      real xiiu(3),tpi,arg
      complex factor1,factor2,factor3
      complex factor1p,factor2p,factor3p,factor
      integer pw1,pw2,pw3

      tpi=2*pimach()
      xiiu=matmul(bmat,point)/tpi_const

      xdnout=cmplx(0.0,0.0)

      if(.false.)then

      arg=(tpi*xiiu(1))/unigrid(1)
      factor1=cmplx(cos(arg),sin(arg))
      arg=(tpi*xiiu(2))/unigrid(2)
      factor2=cmplx(cos(arg),sin(arg))
      arg=(tpi*xiiu(3))/unigrid(3)
      factor3=cmplx(cos(arg),sin(arg))

      do pw3=-unigrid(4),unigrid(4)
       factor3p=(factor3)**pw3
       do pw2=-unigrid(4),unigrid(4)
        factor2p=(factor2)**pw2
        do pw1=-unigrid(4),unigrid(4)
         factor1p=(factor1)**pw1

          factor=factor1p*factor2p*factor3p
          xdnout=xdnout+factor*wannint(pw1,pw2,pw3)

        enddo
       enddo
      enddo

      else

      do pw3=-unigrid(4),unigrid(4)
       do pw2=-unigrid(4),unigrid(4)
        do pw1=-unigrid(4),unigrid(4)
          arg=tpi*(pw1*xiiu(1)/unigrid(1)+pw2*xiiu(2)/unigrid(2)+
     +                  pw3*xiiu(3)/unigrid(3))
          factor=cmplx(cos(arg),sin(arg))
          xdnout=xdnout+factor*wannint(pw1,pw2,pw3)

        enddo
       enddo
      enddo

      endif
      END SUBROUTINE wann_lapw_int_plot
      END MODULE m_wann_lapw_int_plot


      SUBROUTINE FLMOON(N,NPH,JD,FRAC)
      PARAMETER (RAD=0.017453293)
      C=N+NPH/4.
      T=C/1236.85
      T2=T**2
      AS=359.2242+29.105356*C
      AM=306.0253+385.816918*C+0.010730*T2
      JD=2415020+28*N+7*NPH
      XTRA=0.75933+1.53058868*C+(1.178E-4-1.55E-7*T)*T2
      IF(NPH.EQ.0.OR.NPH.EQ.2)THEN
        XTRA=XTRA+(0.1734-3.93E-4*T)*SIN(RAD*AS)-0.4068*SIN(RAD*AM)
      ELSE IF(NPH.EQ.1.OR.NPH.EQ.3)THEN
        XTRA=XTRA+(0.1721-4.E-4*T)*SIN(RAD*AS)-0.6280*SIN(RAD*AM)
      ELSE
        PAUSE 'NPH is unknown.'
      ENDIF
      IF(XTRA.GE.0.)THEN
        I=INT(XTRA)
      ELSE
        I=INT(XTRA-1.)
      ENDIF
      JD=JD+I
      FRAC=XTRA-I
      RETURN
      END