      SUBROUTINE POLSYS(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,
     $     SSPAR,NUMRR,NN,MMAXT,TTOTDG,LENWK,LENIWK,
     $     LAMBDA,ROOTS,ARCLEN,NFE,WK,IWK)
C
C POLSYS FINDS ALL (COMPLEX) SOLUTIONS TO A SYSTEM
C F(X)=0 OF N POLYNOMIAL EQUATIONS IN N UNKNOWNS
C WITH REAL COEFFICIENTS. IF IFLG=10 OR IFLG=11, POLSYS
C RETURNS THE SOLUTIONS AT INFINITY ALSO.
C
C THE SYSTEM F(X)=0 IS DESCRIBED VIA THE COEFFICENTS,
C "COEF", AND THE PARAMETERS "N, NUMT, KDEG", AS FOLLOWS.
C
C
C       NUMT(J)
C
C F(J) = SUM  COEF(J,K) * X(1)**KDEG(J,1,K)...X(N)**KDEG(J,N,K)
C
C        K=1
C
C FOR J=1, ..., N.
C
C
C POLSYS HAS TWO MAIN RUN OPTIONS:  AUTOMATIC SCALING AND
C THE PROJECTIVE TRANSFORMATION.  THESE ARE EVOKED VIA THE
C FLAG "IFLG1", AS DESCRIBED BELOW.  THE OTHER INPUT
C PARAMETERS ARE THE SAME WHETHER ONE OR BOTH OF THESE OPTIONS
C ARE SPECIFIED, AND THE OUTPUT IS ALWAYS RETURNED UNSCALED
C AND UNTRANSFORMED.
C
C IF AUTOMATIC SCALING IS SPECIFIED, THEN THE INPUT
C COEFFICIENTS ARE MODIFIED BY SUBROUTINE  SCLGNP . THE PROBLEM
C IS SOLVED WITH THE SCALED COEFFICIENTS AND SCALED VARIABLES.
C THE COEFFICIENTS ARE RETURNED SCALED.
C
C IF THE PROJECTIVE TRANSFORMATION IS SPECIFIED, THEN
C ESSENTIALLY THE SYSTEM IS REFORMULATED IN HOMOGENEOUS
C COORDINATES, Z(1), ..., Z(N+1), AND SOLVED IN COMPLEX
C PROJECTIVE SPACE.  THE RESULTING SOLUTIONS ARE
C UNTRANSFORMED VIA
C
C X(J) = Z(J)/Z(N+1)   J=1, ..., N.
C
C ON RETURN,
C
C ROOTS(1,J,M) = REAL PART OF X(J) FOR THE M-TH PATH,
C
C ROOTS(2,J,M) = IMAGINARY PART OF X(J) FOR THE M-TH PATH,
C
C FOR J=1, ..., N, AND
C
C ROOTS(1,N+1,M) = REAL PART OF Z(N+1) FOR THE M-TH PATH,
C
C ROOTS(2,N+1,M) = IMAGINARY PART OF Z(N+1) FOR THE M-TH PATH.
C
C IF ROOTS(*,N+1,M) IS SMALL, THEN THE ASSOCIATED SOLUTION
C SHOULD BE REGARDED AS BEING "NEAR INFINITY".  NOTE THAT,
C WHEN THE PROJECTIVE TRANSFORMATION HAS BEEN SPECIFIED, THE
C ROOTS VALUES HAVE BEEN UNTRANSFORMED -- THAT IS, DIVIDED
C THROUGH BY Z(N+1) -- UNLESS SUCH DIVISION WOULD HAVE CAUSED
C OVERFLOW.  IN THIS LATTER CASE, THE AFFECTED COMPONENTS OF
C ROOTS ARE SET TO THE LARGEST FLOATING POINT NUMBER (MACHINE
C INFINITY).
C
C THE CODE CAN BE MODIFIED EASILY TO SOLVE SYSTEMS WITH COMPLEX
C COEFFICIENTS,  COEF .  ONLY THE SUBROUTINES  INITP  AND  FFUNP
C NEED BE CHANGED.
C
C THE FORTRAN COMPLEX DECLARATION IS NOT USED IN POLSYS.
C COMPLEX VARIABLES ARE REPRESENTED BY REAL ARRAYS WITH FIRST
C INDEX DIMENSIONED 2 AND COMPLEX OPERATIONS ARE EVOKED BY
C SUBROUTINE CALLS.
C
C THE TOTAL NUMBER OF PATHS THAT WILL THE TRACKED (IF
C IFLG2(M)=-2 FOR ALL M) IS EQUAL TO THE "TOTAL DEGREE" OF THE
C SYSTEM, TOTDG.   TOTDG IS EQUAL TO THE PRODUCTS OF THE
C DEGREES OF ALL THE EQUATIONS IN THE SYSTEM.  THE DEGREE OF
C AN EQUATION IS THE MAXIMUM OF THE DEGREES OF ITS TERMS.  THE
C DEGREE OF A TERM IS THE SUM OF THE DEGREES OF THE VARIABLES.
C THUS, TOTDG = IDEG(1) * ... * IDEG(N) WHERE IDEG(J) =
C MAX {JDEG(J,K) | K=1,...,NUMT(J)} WHERE JDEG(J,K) = KDEG(J,1,K) +
C ... + KDEG(J,N,K).
C
C IFLG1  DETERMINES WHETHER THE SYSTEM IS TO BE AUTOMATICALLY
C SCALED BY  POLSYS  AND WHETHER THE PROJECTIVE TRANSFORMATION
C OF THE SYSTEM IS TO BE AUTOMATICALLY EVOKED BY POLSYS.  SEE
C "ON INPUT" BELOW.
C
C IFLG2, EPSBIG, EPSSML, AND  SSPAR  TELL THE PATH TRACKER
C POLYNF  WHICH PATHS TO TRACK AND SET PARAMETERS FOR THE PATH
C TRACKER.
C
C NUMRR  TELLS  POLSYS  HOW MANY MULTIPLES OF 1000 STEPS TO TRY
C BEFORE ABANDONING A PATH.
C
C NN, MMAXT, TTOTDG, LENWK, LENIWK  GIVE THE DIMENSIONS OF ARRAYS.
C
C THE OUTPUT CONSISTS OF  IFLG1, AND OF  LAMBDA, ROOTS, ARCLEN, AND
C NFE  FOR EACH PATH.  IFLG1  RETURNS INPUT DATA ERROR INFORMATION.
C ROOTS  GIVES THE SOLUTIONS THEMSELVES, WHILE  LAMBDA, ARCLEN,
C AND  NFE  GIVE INFORMATION ABOUT THE ASSOCIATED PATHS.
C
C THE FOLLOWING SUBROUTINES ARE USED DIRECTLY OR INDIRECTLY BY
C POLSYS:
C         SPECIAL FOR POLSYS:
C           POLYP , INITP , STRPTP ,
C           OTPUTP , RHO , RHOJAC ,
C           HFUNP , HFUN1P , GFUNP , FFUNP ,
C           MULP , POWP , DIVP,
C           SCLGNP.
C         FROM THE GENERAL HOMPACK ROUTINES:
C           POLYNF , STEPNF , TANGNF , ROOTNF , ROOT ,
C           QRFAQF, QRSLQF , D1MACH , DDOT , DNRM2.
C
C ON INPUT:
C
C N  IS THE NUMBER OF EQUATIONS AND VARIABLES.
C
C NUMT(1:NN)  IS AN INTEGER ARRAY.  NUMT(J)  IS THE NUMBER OF TERMS
C   IN THE JTH EQUATION FOR J=1 TO N.
C
C COEF(1:NN,1:MMAXT)  IS A REAL ARRAY.  COEF(J,K)  IS
C   THE K-TH COEFFICIENT OF THE J-TH EQUATION FOR J=1 TO N,
C   K=1 TO NUMT(J).
C
C KDEG(1:NN,1:NN+1,1:MMAXT)  IS AN INTEGER ARRAY.
C   KDEG(J,L,K)  IS THE DEGREE OF THE L-TH VARIABLE IN THE K-TH
C   TERM OF THE J-TH EQUATION FOR  J=1 TO N, L=1 TO N, K=1 TO NUMT(J).
C
C IFLG1 =
C   00  IF THE PROBLEM IS TO BE SOLVED WITHOUT
C       CALLING POLSYS' SCALING ROUTINE, SCLGNP, AND
C       WITHOUT USING THE PROJECTIVE TRANSFORMTION.
C
C   01  IF SCALING BUT NO PROJECTIVE TRANSFORMATION IS TO BE USED.
C
C   10  IF NO SCALING BUT PROJECTIVE TRANSFORMATION IS TO BE USED.
C
C   11  IF BOTH SCALING AND PROJECTIVE TRANSFORMATION ARE TO BE USED.
C
C IFLG2(1:TTOTDG)  IS AN INTEGER ARRAY.  IF IFLG2(M) = -2, THEN THE
C   M-TH PATH IS TRACKED.  OTHERWISE THE M-TH PATH IS SKIPPED.
C   THUS, TO FIND ALL SOLUTIONS SET IFLG2(M) = -2 FOR M=1,...,TOTDG.
C   SELECTED PATHS CAN BE RERUN BY SETTING IFLG2(M)=-2 FOR
C   THE PATHS TO BE RERUN AND IFLG(M).NE.-2 FOR THE OTHERS.
C
C EPSBIG  IS THE LOCAL ERROR TOLERANCE ALLOWED THE PATH TRACKER ALONG
C   THE PATH.  ARCRE AND ARCAE (IN  POLYNF ) ARE SET TO  EPSBIG.
C
C EPSSML  IS THE ACCURACY DESIRED FOR THE FINAL SOLUTION.  ANSRE AND
C   ANSAE (IN  POLYNF ) ARE SET TO  EPSSML.
C
C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P)  IS
C    A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION.
C    IF  SSPAR(J) .LE. 0.0  ON INPUT, IT IS RESET TO A DEFAULT VALUE
C    BY  POLYNF .  OTHERWISE THE INPUT VALUE OF  SSPAR(J)  IS USED.
C    SEE THE COMMENTS IN  POLYNF  AND IN  STEPNF  FOR MORE INFORMATION
C    ABOUT THESE CONSTANTS.
C
C NUMRR  IS THE NUMBER OF MULTIPLES OF 1000 STEPS THAT WILL BE TRIED
C   BEFORE ABANDONING A PATH.
C
C NN  IS THE DECLARED DIMENSION OF  NUMT  AND OF THE
C   FIRST INDEX OF  COEF  AND  KDEG .  THE SECOND INDEX OF
C   KDEG  AND  ROOTS  IS DIMENSIONED NN+1.  NN  MUST
C   BE GREATER THAN OR EQUAL TO N.
C
C MMAXT  IS THE DECLARED DIMENSION OF THE SECOND INDEX OF
C   COEF  AND THE THIRD INDEX OF  KDEG.  MMAXT  MUST BE
C   GREATER THAN OR EQUAL TO THE MAXIMUM NUMBER OF
C   TERMS IN EACH EQUATION.  IN OTHER WORDS,
C   MMAXT .GE. MAX {NUMT(J) | J=1, ..., N} .
C
C TTOTDG  IS THE DECLARED DIMENSION OF  IFLG2 , LAMBDA , ARCLEN ,
C   NFE , AND OF THE THIRD INDEX OF  ROOTS.  TTOTDG
C   MUST BE GREATER THAN OR EQUAL TO TOTDG, THE TOTAL
C   DEGREE OF THE SYSTEM.
C
C LENWK  IS THE DIMENSION OF THE WORKSPACE  WK .  LENWK  MUST
C   BE GREATER THAN OR EQUAL TO
C     21 + 61*N + 10*N**2 + 7*N*MMAXT + 4*N**2*MMAXT.
C
C LENIWK  IS THE DIMENSION OF THE WORKSPACE  IWK .  LENIWK  MUST BE
C   GREATER THAN OR EQUAL TO  43 + 7*N + N*(N+1)*MMAXT.
C
C
C ON OUTPUT:
C
C N, NUMT, COEF, KDEG, NN, MMAXT, TTOTDG, LENWK, AND  LENIWK
C   ARE UNCHANGED.
C
C IFLG1=
C   -1  IF  NN  IS TOO SMALL.
C   -2  IF  MMAXT  IS TOO SMALL.
C   -3  IF  TTOTDG  IS TOO SMALL.
C   -4  IF  LENWK  IS TOO SMALL.
C   -5  IF  LENIWK  IS TOO SMALL.
C   -6  IF  IFLG1  ON INPUT IS NOT 00 OR 01 OR 10 OR 11.
C   UNCHANGED OTHERWISE.
C
C IFLG2(1:TOTDG)  GIVES INFORMATION ABOUT HOW THE M-TH PATH TERMINATED:
C IFLG2(M) =
C   1   NORMAL RETURN.
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  INCREASE  EPSBIG
C       AND  EPSSML  AND RERUN.
C
C   3   MAXIMUM NUMBER OF STEPS EXCEEDED.  TO TRACK THE PATH FURTHER,
C       INCREASE  NUMRR  AND RERUN THE PATH.  HOWEVER, THE PATH MAY
C       BE DIVERGING, IF THE  LAMBDA  VALUE IS NEAR 1 AND THE  ROOTS
C       VALUES ARE LARGE.
C
C   4   JACOBIAN MATRIX DOES NOT HAVE FULL RANK.  THE ALGORITHM
C       HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE
C       FOLLOWED ANY FURTHER).
C
C   5   THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE
C       HOMOTOPY MAP AND IS NOT MAKING PROGRESS.  THE ERROR TOLERANCES
C       EPSBIG  AND  EPSSML  WERE TOO LENIENT.  THE PROBLEM SHOULD BE
C       RESTARTED WITH SMALLER ERROR TOLERANCES.
C
C   6   THE NORMAL FLOW NEWTON ITERATION IN  STEPNF  OR  ROOTNF
C       FAILED TO CONVERGE.  THE ERROR TOLERANCE  EPSBIG  MAY BE TOO
C       STRINGENT.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C LAMBDA(M)  IS THE FINAL LAMBDA VALUE FOR THE M-TH PATH, M = 1, ...,
C   TOTDG, WHERE LAMBDA IS THE CONTINUATION PARAMETER.
C
C ROOTS(1,J,M), ROOTS(2,J,M)  ARE THE REAL AND IMAGINARY PARTS
C   OF THE JTH VARIABLE RESPECTIVELY, FOR J = 1,...,N, FOR
C   THE M-TH PATH, FOR M = 1,...,TOTDG.  IF  IFLG1 = 10 OR 11, THEN
C   ROOTS(1,N+1,M)  AND  ROOTS(2,N+1,M)  ARE THE REAL AND
C   IMAGINARY PARTS RESPECTIVELY OF THE PROJECTIVE
C   COORDINATE OF THE SOLUTION.
C
C ARCLEN(M)  IS THE ARC LENGTH OF THE M-TH PATH FOR M = 1, ..., TOTDG.
C
C NFE(M)  IS THE NUMBER OF JACOBIAN MATRIX EVALUATIONS REQUIRED TO
C   TRACK THE M-TH PATH FOR M =1, ..., TOTDG.
C
C ----------------------------------------------------------------------
C TYPE DECLARATIONS FOR INPUT AND OUTPUT
      INTEGER N,NUMT,KDEG,IFLG1,IFLG2,NUMRR,NN,MMAXT,
     $  TTOTDG,LENWK,LENIWK,NFE,IWK
      DOUBLE PRECISION COEF,EPSBIG,EPSSML,SSPAR,LAMBDA,ROOTS,
     $  ARCLEN,WK
C
C ARRAY DECLARATIONS FOR INPUT AND OUTPUT
      DIMENSION NUMT(NN),KDEG(NN,NN+1,MMAXT),IFLG2(TTOTDG),
     $  NFE(TTOTDG),IWK(LENIWK)
      DIMENSION COEF(NN,MMAXT),SSPAR(8),LAMBDA(TTOTDG),
     $  ROOTS(2,NN+1,TTOTDG), ARCLEN(TTOTDG),WK(LENWK)
C
C TYPE DECLARATIONS FOR VARIABLES
      INTEGER I,IDEG,IIDEG,IWKOFF,J,K,L,LENIWW,LENWKK,LIWK,LWK,
     $  MAXT,N2,TOTDG,WKOFF
C
C ARRAY DECLARATIONS FOR VARIABLES
      DIMENSION LWK(19),LIWK(4),WKOFF(19),IWKOFF(4)
C
C CHECK THAT BASIC DIMENSIONAL PARAMETERS ARE BIG ENOUGH
C
      IF(NN.LT.N) THEN
        IFLG1=-1
        RETURN
      END IF
      MAXT=0
      DO 50 J=1,N
        IF(MAXT.LT.NUMT(J))MAXT=NUMT(J)
 50   CONTINUE
      IF(MMAXT.LT.MAXT) THEN
        IFLG1=-2
        RETURN
      END IF
      TOTDG=1
      DO 80 J=1,N
         IDEG=0
         DO 70 K=1,NUMT(J)
             IIDEG=0
             DO 60 L=1,N
                IIDEG=IIDEG+KDEG(J,L,K)
 60          CONTINUE
             IF(IIDEG.GT.IDEG)IDEG=IIDEG
 70      CONTINUE
         TOTDG=TOTDG*IDEG
 80   CONTINUE
      IF(TTOTDG.LT.TOTDG) THEN
        IFLG1=-3
        RETURN
      END IF
      LENWKK = 21 + 61*N + 10*N**2 + 7*N*MMAXT + 4*N**2*MMAXT
      IF(LENWK.LT.LENWKK) THEN
        IFLG1=-4
        RETURN
      END IF
      LENIWW = 43 +  7*N + N*(N+1)*MMAXT
      IF(LENIWK.LT.LENIWW) THEN
        IFLG1=-5
        RETURN
      END IF
      IF(IFLG1.NE.0.AND.IFLG1.NE.1.AND.IFLG1.NE.10.AND.IFLG1.NE.11) THEN
        IFLG1=-6
        RETURN
      END IF
C
C VARIABLES THAT ARE PASSED IN ARRAY WK: (LENGTHS ARE IN THE
C INTEGER ARRAY LWK.)
C
C    VARIABLE NAME       LENGTH
C
C    1   PDG               N2
C    2   QDG               N2
C    3   R                 N2
C    4   FACV              N
C    5   CL                2*(N+1)
C    6   Y                 N2+1
C    7   YP                N2+1
C    8   YOLD              N2+1
C    9   YPOLD             N2+1
C   10   QR                N2*(N2+2)
C   11   ALPHA             N2
C   12   TZ                N2+1
C   13   W                 N2+1
C   14   WP                N2+1
C   15   Z0                N2+1
C   16   Z1                N2+1
C   17   SSPAR             8
C   18   PAR               2 + 28*N + 6*N**2 + 7*N*MMAXT + 4*N**2*MMAXT
C
C VARIABLES THAT ARE PASSED IN ARRAY IWK: (LENGTHS ARE IN THE
C INTEGER ARRAY LIWK.)
C
C    VARIABLE NAME       LENGTH
C
C    1   IDEG              N
C    2   ICOUNT            N
C    3   PIVOT             N2+1
C    4   IPAR              42 + 2*N + N*(N+1)*MMAXT
C
      N2=2*N
      LWK(1)= N2
      LWK(2)= N2
      LWK(3)= N2
      LWK(4)= N
      LWK(5)= 2*(N+1)
      LWK(6)= N2+1
      LWK(7)= N2+1
      LWK(8)= N2+1
      LWK(9)= N2+1
      LWK(10)=N2*(N2+2)
      LWK(11)=N2
      LWK(12)=N2+1
      LWK(13)=N2+1
      LWK(14)=N2+1
      LWK(15)=N2+1
      LWK(16)=N2+1
      LWK(17)=8
      LWK(18)= 2 + 28*N + 6* N**2 + 7*N*MMAXT + 4* N**2 *MMAXT
C
      LIWK(1)=N
      LIWK(2)=N
      LIWK(3)=2*N+1
      LIWK(4)= 42 + 2*N + N*(N+1)*MMAXT
C
C WKOFF AND IWKOFF ARE OFFSETS THAT DEFINE THE VARIABLES LISTED ABOVE
C
      WKOFF(1)=1
      DO 100 I=2,18
          WKOFF(I)=WKOFF(I-1)+LWK(I-1)
 100  CONTINUE
      IWKOFF(1)=1
      DO 200 I=2,4
          IWKOFF(I)=IWKOFF(I-1)+LIWK(I-1)
 200  CONTINUE
      DO 300 J=1,8
        WK(WKOFF(17) + (J-1))=SSPAR(J)
 300  CONTINUE
C
      CALL POLYP(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,
     $ NUMRR,NN,MMAXT,TTOTDG,LAMBDA,ROOTS,ARCLEN,NFE,TOTDG,
     $ WK( WKOFF( 1)),WK( WKOFF( 2)),WK( WKOFF( 3)),WK( WKOFF( 4)),
     $ WK( WKOFF( 5)),WK( WKOFF( 6)),WK( WKOFF( 7)),WK( WKOFF( 8)),
     $ WK( WKOFF( 9)),WK( WKOFF(10)),WK( WKOFF(11)),WK( WKOFF(12)),
     $ WK( WKOFF(13)),WK( WKOFF(14)),WK( WKOFF(15)),WK( WKOFF(16)),
     $ WK( WKOFF(17)),WK( WKOFF(18)),
     $IWK(IWKOFF( 1)),IWK(IWKOFF( 2)),IWK(IWKOFF( 3)),IWK(IWKOFF( 4)))
C
      RETURN
      END


! Flat plate collector subroutine
! Lubello: mar 2020

! References
! 1) Duffie, J. A., & Beckman, W. A. (2013). Solar engineering of thermal processes. John Wiley & Sons. Chapter 6, pg.290

subroutine SolarColl(Area,        & ! (I)  Flat solar collector area       [m^2]
                     Fr,          & ! (I)  Collector heat removal factor   [-] default: 0.75-0.80
                     SolIrr,      & ! (I)  Solar irradiance                [W/m^2]
                     TauAlpha,    & ! (I)  From eq. 5.9.3                  [-] deafault: 0.80
                     Ul,          & ! (I)  Heat transfer coefficient       [W/(m^2*K)] realistic value: 9.5 (Duffie pg.294)
                     Tin,         & ! (I)  Fluid temperature in            [K]
                     Tair,        & ! (I)  Air temperature                 [K]
                     CostSolColl, & ! (I)  Cost per m^2 panels             [eur/m^2]
                     QQdem,       & ! (I)  Energy demand                   [kWh]
                     SoC,         & ! (IO) State of charge                 [-]
                     QQproduced,  & ! (O)  Heat produced (might be stored) [kWh]
                     QQsolColl,   & ! (O)  Heat out system (panels + tank) [kWh]
                     QQdisc,      & ! (O)  Heat discarded (would result in SoC > 1) [kWh]
                     CapexSolColl)  ! (O)  Capex                           [eur]

      USE MODparam,  ONLY: timestep,NsecHour,cpH2O,rhoStdh2o

      implicit real(8) (a-h,o-z), integer(i-n)

      real(8), intent(IN   ) :: Area,Fr,SolIrr,taualpha,Ul,Tin,Tair,CostSolColl,QQdem
      real(8), intent(INOUT) :: SoC
      real(8), intent(  OUT) :: QQsolColl,QQproduced,CapexSolColl

      ! Tank sizing and initial charge

      VolTank  = Area*75.d0/1.d3                                      ! [m3]
      Capacity = VolTank*rhoStdh2o*cpH2O*(60.d0-45.d0)/dble(NsecHour) ! [kWh]
      Charge   = Capacity *SoC                                        ! [kWh]

      ! Power (converted to energy) produced by the panels

      Rad = SolIrr*TauAlpha ! [W/m2]
      Disp = Ul*(Tin-Tair)  ! [W/m2]

      if(Rad .gt. Disp) then
        QQ = Area*Fr*(Rad-Disp)/1.d3 ! [kW]
      else
        QQ = 0.d0 ! [kW]
      endif

      QQproduced = QQ * timestep ! [kWh]

      ! Tank balances and final SoC

      Charge = Charge*(1.d0 - 0.05d0)

      if (QQproduced .ge. abs(QQdem)) then
        QQsolColl = abs(QQdem)
        Charge = Charge + (QQproduced - abs(QQdem))
      else

        if (Charge .gt. (abs(QQdem) - QQproduced)) then
          QQsolColl = abs(QQdem)
          Charge = Charge - (abs(QQdem) - QQproduced)
        else
          QQsolColl = QQproduced + Charge
          Charge = 0.d0
        endif

      endif

      if (Charge .gt. Capacity) then
        QQdisc = Charge - Capacity
        Charge = Capacity
      else
      endif

      SoC = Charge/Capacity

      CapexSolColl = Area*CostSolColl ! Capex

       return

end subroutine SolarColl


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 CLOSEL (MP, ML, N, COOR, ILINE, LTYPE, LCON, LINKP,
     &   LINKL, X, Y, BIFIND, IFIND, ADDCEN, XCHOLD, YCHOLD)
C***********************************************************************

C  SUBROUTINE CLOSEL = FINDS CLOSEST PERPENDICULAR BISECTED LINE

C***********************************************************************

C  SUBROUTINE CALLED BY:
C     BISECT   =

C***********************************************************************

C  SUBROUTINES CALLED:
C     DLPARA = DETERMINES LINE PARAMETERS FROM TWO POINTS

C***********************************************************************

      DIMENSION COOR(2, MP), ILINE(ML), LCON(3, ML), LTYPE(ML), N(29)
      DIMENSION LINKL(2, ML), LINKP(2, MP)

      LOGICAL BIFIND, BAD, ADDLNK, ADDCEN, ERR

      PI = ATAN2(0.0, -1.0)
      TWOPI = PI + PI

C  FIND THE CLOSEST LINE ABOVE THE POINT INPUT

      BIFIND = .FALSE.
      ADDLNK = .FALSE.
      IFIND = 0
      DIST = 100000.
      DO 100 I = 1, N(19)
         CALL LTSORT (ML, LINKL, I, II, ADDLNK)
         IF (II .GT. 0) THEN
            KT = LTYPE(II)
            CALL LINEPR (ML, MP, LINKP, LCON, II, I1, I2, I3, J1, J2,
     &         J3)
            IF ((J1 .GT. 0) .AND. (J2 .GT. 0)) THEN
               IF (KT .EQ. 1) THEN

C  GET THE PARAMETERS FOR THE LINE

                  CALL DLPARA (COOR(1, J1), COOR(2, J1), COOR(1, J2),
     &               COOR(2, J2), XM1, B1, BAD)

C  GET DISTANCE FOR VERTICAL LINE

                  IF (BAD) THEN
                     DTRY = ABS(COOR(1, J1) - X)
                     XTRY = COOR(1, J1)
                     YTRY = Y

C  GET DISTANCE FOR HORIZONTAL LINE

                  ELSE IF (ABS(XM1) .LT. .000001) THEN
                     DTRY = ABS(COOR(2, J1) - Y)
                     XTRY = X
                     YTRY = COOR(2, J1)

C  GET PERPENDICULAR DISTANCE TO ARBITRARY LINE

                  ELSE
                     XM2 = -1./XM1
                     B2 = Y - (XM2*X)
                     XTRY = (B2 - B1)/(XM1 - XM2)
                     YTRY = (XM1*XTRY) + B1
                     DTRY = SQRT((X - XTRY)**2 + (Y - YTRY)**2)
                  END IF
                  IF (DTRY .LE. DIST) THEN
                     X1 = MIN(COOR(1, J1), COOR(1, J2))
                     X2 = MAX(COOR(1, J1), COOR(1, J2))
                     Y1 = MIN(COOR(2, J1), COOR(2, J2))
                     Y2 = MAX(COOR(2, J1), COOR(2, J2))
                     IF ((XTRY .GE. X1) .AND. (XTRY .LE. X2) .AND.
     &                  (YTRY .GE. Y1) .AND. (YTRY .LE. Y2)) THEN
                        DIST = DTRY
                        XHOLD = XTRY
                        YHOLD = YTRY
                        IFIND = I
                        BIFIND = .TRUE.
                     END IF
                  END IF

C  CHECK DISTANCES TO CIRCULAR ARCS

               ELSE IF ((KT .EQ. 3).OR.(KT .EQ. 4).OR.(KT .EQ. 6)) THEN

C  FIRST GET THETA1, THETA2, THETAT, R1, R2, AND RTRY

                  CALL ARCPAR (MP, KT, ILINE(II), COOR, LINKP, J1, J2,
     &               J3, I3, XCEN, YCEN, THETA1, THETA2, TANG, R1, R2,
     &               ERR, ICCW, ICW, XK, XA)

                  IF ((Y .EQ. YCEN) .AND. (X .EQ. XCEN)) THEN
                     RTRY = 0.
                     THETAT = (THETA1 + THETA2)*.5
                  ELSE
                     THETAT = ATAN2(Y - YCEN, X - XCEN)
                     RTRY = SQRT( ((X - XCEN)**2)  +  ((Y - YCEN)**2))
                  END IF

C  SEE IF THE POINT ANGLE IS WITHIN THE BEGINNING AND ENDING ANGLES

                  IF ( ((THETAT .LE. THETA2) .AND. (THETAT .GE. THETA1))
     &               .OR. ((THETAT + TWOPI .LE. THETA2) .AND.
     &               (THETAT + TWOPI .GE. THETA1)) ) THEN

C  CALCULATE THE ARC RADIUS AT THAT ANGLE

                     RADIUS = XA*EXP(XK*THETAT)
                     DTRY = ABS(RADIUS - RTRY)

C  CHECK TO SEE IF THE ARC IS THE CLOSEST

                     IF (DTRY .LE. DIST) THEN
                        DIST = DTRY
                        XHOLD = XCEN + COS(THETAT)*RADIUS
                        YHOLD = YCEN + SIN(THETAT)*RADIUS
                        IFIND = I
                        IF ((KT .EQ. 4).OR.(KT .EQ. 6)) THEN
                           ADDCEN = .TRUE.
                           XCHOLD = XCEN
                           YCHOLD = YCEN
                        ELSE
                           ADDCEN = .FALSE.
                        END IF
                        BIFIND = .TRUE.
                     END IF
                  END IF
               END IF
            END IF
         END IF
  100 CONTINUE
      X = XHOLD
      Y = YHOLD

      RETURN
      END


!--------------------------------------------------------------------------------------------------
! MODULE: cgto_mod
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date March, 2019
!
!> @brief Contains the cgto_subshell type and accompanying subroutines.
!--------------------------------------------------------------------------------------------------
module cgto_mod
    use global_defs
    use ang_mom_defs, only : amp
    implicit none

    private
    public :: cgto_subshell
    public :: cgto_one_el
    public :: gto_norms
    public :: cgto_norm
    public :: cngto_norm

    !----------------------------------------------------------------------------------------------
    ! TYPE: cgto_subshell
    !
    !> @brief Contracted Gaussian Type Orbital
    !----------------------------------------------------------------------------------------------
    type cgto_subshell
        integer :: l !< Angular momentum.
        character(len=1) :: typ !< Type of subshell.
        integer :: n_prim = 0 !< Number of primitive Gaussians.
        real(dp), allocatable :: z(:) !< Zeta coefficients. Dimensions: n_prim.
        real(dp), allocatable :: b(:) !< Beta coefficients. Dimensions: n_prim.
        real(dp), allocatable :: cb(:, :) !< Beta coefficients normalized for each cartesian function.
                                          !! Dimensions: n_prim x n_cart(l)
        logical :: init_cb = .false.
        logical :: inorm_b = .false.
        logical :: norm_gto = .false. !< Normalized primitive GTOs.
    contains
        procedure :: norm_b => cngto_norm_b
        procedure :: gen_cb => cgto_gen_cb
    end type cgto_subshell

contains

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: cgto_gen_cb
    !> @brief Normalize contracted Cartesian GTO.
    !> @details
    !! Multiply b coefficients by the norms of their respective primitive GTOs (if norm_gto) and by
    !! the norm of the full expansion for each combination of {lx, ly, lz} with lx+ly+lz=l.
    !----------------------------------------------------------------------------------------------
    subroutine cgto_gen_cb(self, norm_ccgto, norm_gto)
        class(cgto_subshell) :: self
        logical, intent(in) :: norm_ccgto
        logical, intent(in) :: norm_gto
        integer :: i, n_cart
        integer, allocatable :: lc(:, :)
        real(dp) :: norm

        n_cart = amp%n_cart(self%l)
        if (allocated(self%cb)) deallocate(self%cb)
        allocate(self%cb(self%n_prim, n_cart))
        allocate(lc(1:3,1:amp%n_cart(self%l)), source=amp%cart(self%l))

        do i = 1, n_cart
            if (norm_gto) then
                self%cb(:, i) = self%b * gto_norms(self%z, lc(1, i), lc(2, i), lc(3, i))
                self%norm_gto = .true.
            else
                self%cb(:, i) = self%b
            end if
            if (norm_ccgto) then
                norm = cgto_norm(self%z, self%cb(:, i), lc(1, i), lc(2, i), lc(3, i))
                self%cb(:, i) = self%cb(:, i) * norm
            end if
        end do
        self%init_cb = .true.
    end subroutine cgto_gen_cb

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: cngto_norm_b
    !
    !> @brief Normalize subshell coefficients assuming primitive Gaussians will also be normalized.
    !> @details
    !! See documentation of cngto_norm function.
    !> @note
    !! This subroutine is redundant if norm_cb is used to normalize the cb coefficients,
    !! but it is the standard normalization for the b coefficients prior to expanding the subshell.
    !----------------------------------------------------------------------------------------------
    subroutine cngto_norm_b(self)
        class(cgto_subshell) :: self
        integer:: i, j
        real(dp) :: bi, bj, zi, zj, pow
        real(dp):: nsum

        self%b = self%b * cngto_norm(self%z, self%b, self%l)
        self%inorm_b = .true.
    end subroutine cngto_norm_b

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: cgto_norm
    !> @brief Norm of a contracted GTOs.
    !----------------------------------------------------------------------------------------------
    function cgto_norm(z, b, lx, ly, lz) result(nsum)
        real(dp), intent(in) :: z(:)
        real(dp), intent(in) :: b(:)
        integer, intent(in) :: lx
        integer, intent(in) :: ly
        integer, intent(in) :: lz
        real(dp):: nsum
        real(dp) :: pow, ggg
        integer :: i, j, n_prim

        n_prim = size(b)
        ggg = gamma(f1o2+lx)*gamma(f1o2+ly)*gamma(f1o2+lz)
        pow = - num3/num2 - lx - ly - lz
        nsum = num0
        do i = 1, n_prim
            do j = 1, n_prim
                nsum = nsum + b(i) * b(j) * (z(i)+z(j))**pow
            end do
        end do
        nsum = 1 / sqrt(nsum * ggg)
    end function cgto_norm

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: cngto_norm
    !
    !> @brief Norm of a contracted GTO assuming primitive Gaussians will also be normalized.
    !> @details
    !! The cGTO is normalized and it is assumed that the b coefficients used here were not
    !! already multiplied by the norms of the primitive functions. This norm depends only on the
    !! total angular momentum and can be used once to normalize the coefficients of the subshell.
    !! The norms of the individual primitive (Cartesian) Gaussians also depend on the components
    !! of the angular momentum and can only be added once the subshell is expanded.
    !----------------------------------------------------------------------------------------------
    function cngto_norm(z, b, l) result(nsum)
        real(dp), intent(in) :: z(:)
        real(dp), intent(in) :: b(:)
        integer, intent(in) :: l
        real(dp):: nsum
        integer:: i, j, n_prim
        real(dp):: pow

        n_prim = size(b)
        nsum = num0
        pow = f3o4 + l / num2
        do i = 1, n_prim
            do j = 1, n_prim
                nsum = nsum + b(i) * b(j) * (2*z(i))**pow * (2*z(j))**pow / (z(i)+z(j))**(num2*pow)
            end do
        end do
        nsum = 1 / sqrt(nsum)
    end function cngto_norm

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: gto_norms
    !> @brief Return norms of primitive cartesian gaussians in a contracted GTO.
    !----------------------------------------------------------------------------------------------
    function gto_norms(z, lx, ly, lz) result(norm)
        real(dp), intent(in) :: z(:)
        integer, intent(in) :: lx
        integer, intent(in) :: ly
        integer, intent(in) :: lz
        real(dp) :: norm(size(z))
        real(dp) :: pow, ggg

        pow = f3o4 + (lx + ly + lz) / num2
        ggg = gamma(f1o2+lx)*gamma(f1o2+ly)*gamma(f1o2+lz)
        norm = (2*z)**pow / sqrt(ggg)
    end function gto_norms

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: cgto_one_el
    !> @brief Calculate one electron operator matrix between two cTGO subshells.
    !----------------------------------------------------------------------------------------------
    function cgto_one_el(cg1, cg2, q1, qc, q2, lc) result(op)
        type(cgto_subshell), intent(in) :: cg1
        type(cgto_subshell), intent(in) :: cg2
        real(dp), intent(in) :: q1(3)
        real(dp), intent(in) :: q2(3)
        integer, intent(in) :: lc(3)
        real(dp), allocatable :: op(:, :)
        real(dp) :: ssum, r2, z1, z2
        real(dp), parameter :: pi_3o2 = pi**(num3/num2)
        real(dp), parameter :: tinydp = 0.00000000000001_dp
        integer :: i, j, m, n
        real(dp) :: qc(3), os_int(3)
        integer, allocatable :: l1(:, :), l2(:, :)

        if (.not. cg1%init_cb) call cg1%gen_cb(.true., .true.)
        if (.not. cg2%init_cb) call cg2%gen_cb(.true., .true.)

        r2 = sum((q1-q2)**2)
        allocate(l1(1:3,1:amp%n_cart(cg1%l)), source=amp%cart(cg1%l))
        allocate(l2(1:3,1:amp%n_cart(cg2%l)), source=amp%cart(cg2%l))
        allocate(op(amp%n_cart(cg1%l), amp%n_cart(cg2%l)), source=num0)
        do i = 1, amp%n_cart(cg1%l)
            do j = 1, amp%n_cart(cg2%l)
                ssum = 0.0_dp
                do m = 1, cg1%n_prim
                    z1 = cg1%z(m)
                    do n = 1, cg2%n_prim
                        z2 = cg2%z(n)
                        os_int = osrec_multi(l1(:, i), lc, l2(:, j), q1, qc, q2, z1, z2)
                        ssum = ssum + cg1%cb(m, i) * cg2%cb(n, j) * product(os_int) * pi_3o2 * &
                        &      (z1+z2) ** (-num3/num2) * exp(-(z1*z2) * r2 / (z1+z2))
                    end do
                end do
                if (abs(ssum) > tinydp) op(i, j) = ssum
            end do
        end do
    end function cgto_one_el

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: osrec_multi
    !> @brief Calls osrec subroutine for each dimension
    !----------------------------------------------------------------------------------------------
    function osrec_multi(l1, lc, l2, q1, qc, q2, z1, z2) result(os_int)
        integer, intent(in) :: l1(:)
        integer, intent(in) :: lc(:)
        integer, intent(in) :: l2(:)
        real(dp), intent(in) :: q1(:)
        real(dp), intent(in) :: qc(:)
        real(dp), intent(in) :: q2(:)
        real(dp), intent(in) :: z1
        real(dp), intent(in) :: z2
        real(dp) :: os_int(size(l1))
        real(dp) :: qp, inv2p, inq(3)
        integer :: i, inl(3)

        inv2p = num1 / num2 / (z1 + z2)
        do i = 1, size(l1)
            inl = [l1(i), l2(i), lc(i)]
            inq = [q1(i), q2(i), qc(i)]
            qp = (z1*q1(i) + z2*q2(i)) / (z1+z2)
            os_int(i) = osrec(inl, inq, qp, inv2p)
        end do
    end function osrec_multi

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: OSRec
    !
    !> @brief Obara-Saika recurrence relations for calculating integrals.
    !> @details
    !! The Obara-Saika recurrence relations for calculating the overlap and multipole integrals of
    !! Cartesian Gaussian functions of arbitrary quantum number:
    !! G(a,q,q0,lq) = (q-q0)^lq * exp(-a * (q-q0)^2)
    !! Integral: S(lq1,lqb,lq3) = < G(a,q,q0a,lqa) | (q-q03)^lq3 | G(b,q,q0b,lqb) >
    !! Recurrence relations:
    !!      S(i+1,j,k) = (qp-q0a) * S(i,j,k) + (i*S(i-1,j,k) + j*S(i,j-1,k) + k*S(i,j,k-1))/2(a+b)
    !!      S(i,j+1,k) = (qp-q0b) * S(i,j,k) + (i*S(i-1,j,k) + j*S(i,j-1,k) + k*S(i,j,k-1))/2(a+b)
    !!      S(i,j,k+1) = (qp-q03) * S(i,j,k) + (i*S(i-1,j,k) + j*S(i,j-1,k) + k*S(i,j,k-1))/2(a+b)
    !
    !> @param inl - The 3 quantum numbers: lqa, lqb and lq3.
    !> @param inq - Coordinates of the centres of the functions: q0a, q0b, q03
    !> @param qp - Position of the Gaussian overlap distribution: qp = (lqa*q0a + lqb*q0b)/(a+b)
    !> @param inv2p - 1/(2(a+b))
    !> @param sout - Result of applying the recurrence relations up to S(lqa,lqb,lq3).
    !!               For the value of the integral this should be multiplied by S(0,0,0).
    !----------------------------------------------------------------------------------------------
    function osrec(inl, inq, qp, inv2p) result(sout)
        integer,intent(in) :: inl(3)
        real(dp),intent(in) :: inq(3)
        real(dp),intent(in) :: qp
        real(dp),intent(in) :: inv2p
        real(dp) :: sout
        integer :: i, j, k, l1, l2, l3
        integer :: ord(3)
        real(dp) :: q1, q2, q3, qp1, qp2, qp3
        real(dp), allocatable :: s(:,:,:)

        if (inl(1)>=inl(2) .and. inl(1)>=inl(3)) then
            if (inl(2)>=inl(3)) then
                ord=[1,2,3]
            else
                ord=[1,3,2]
            end if
        else if (inl(2)>=inl(3)) then
            if (inl(1)>=inl(3)) then
                ord=[2,1,3]
            else
                ord=[2,3,1]
            end if
        else
            if (inl(1)>=inl(2)) then
                ord=[3,1,2]
            else
                ord=[3,2,1]
            end if
        end if
        l1=inl(ord(1))
        l2=inl(ord(2))
        l3=inl(ord(3))
        q1=inq(ord(1))
        q2=inq(ord(2))
        q3=inq(ord(3))

        allocate(s(0:l1,0:l2,0:l3))
        s = 0.0_dp
        qp1 = qp - q1
        qp2 = qp - q2
        qp3 = qp - q3
        s(0,0,0) = 1.0_dp
        if (l1>0) s(1,0,0) = qp1
        if (l2>0) then
            s(0,1,0) = qp2
            s(1,1,0) = qp1 * qp2 + inv2p
        end if
        do i=2,l1
            s(i,0,0) = qp1*s(i-1,0,0) + inv2p*(i-1)*s(i-2,0,0)
        end do
        if (l2>0) then
            do i=2,l1
                s(i,1,0) = qp2*s(i,0,0) + inv2p * i *s(i-1,0,0)
            end do
        end if
        do j=2,l2
            s(0,j,0) = qp1*s(0,j-1,0) + inv2p*(j-1)*s(0,j-2,0)
            s(1,j,0) = qp2*s(0,j,0)   + inv2p* j   *s(0,j-1,0)
        end do
        do j=2,l2
            do i=2,l1
                s(i,j,0) = qp2*s(i,j-1,0) + inv2p * (i*s(i-1,j-1,0) + (j-1)*s(i,j-2,0))
            end do
        end do
        do j=l2-l3+1,l2
            do i=l3-l2+j,l1
                s(i,j,1) = qp3*s(i,j,0) + inv2p * (i*s(i-1,j,0) + j*s(i,j-1,0))
            end do
        end do
        do k=2,l3
            do j=l2-l3+k,l2
                do i=l3-l2+j-k+1,l1
                    s(i,j,k)=qp3*s(i,j,k-1) + inv2p * (i*s(i-1,j,k-1) + j*s(i,j-1,k-1) + (k-1)*s(i,j,k-2))
                end do
            end do
        end do

        sout = s(l1,l2,l3)
        deallocate(s)
    end function osrec

end module cgto_mod


C................................................................       EXA   10
      SUBROUTINE EXACT(X, U)                                            EXA   20
      REAL*8 U(4), X
C     EXACT SOLUTION
      U(1) = .25*(10.*LOG(2.)-3.)*(1.-X) + .5*(1./X+(3.+X)*LOG(X)-X)
      U(2) = -.25*(10.*LOG(2.)-3.) + .5*(-1./X/X+LOG(X)+(3.+X)/X-1.)
      U(3) = .5*(2./X**3+1./X-3./X/X)
      U(4) = .5*(-6./X**4-1./X/X+6./X**3)
      RETURN
      END


      SUBROUTINE AKP2
C
      COMPLEX AI
C
      COMMON/BLK1/SCRK,SPS,SNS,DSTR,AI,PI,DEL,SIGMA,BETA,RES
C
      GAM=SQRT(DEL**2-SCRK**2)
      S1=SNS*GAM
      C1=(SIGMA-S1)/2.0
      C2=(SIGMA+S1)/2.0
      DGDA=DEL/GAM
      D1=SPS/2.0
      D2=SNS/2.0*DGDA
      DC1DA=D1-D2
      DC2DA=D1+D2
      RES=1.0/GAM*DGDA+SNS*COS(S1)/SIN(S1)*DGDA
     1-COS(C1)/SIN(C1)*DC1DA-COS(C2)/SIN(C2)*DC2DA
      RETURN
      END


      function polarhalodens(r,ctheta,l)

      common /legendre/ plcon(0:40)
c returns density at r,theta, multiplied by the lth harmonic
c (must integrate this over theta to get the harmonic coeff)
      z=r*ctheta
      s=r*sqrt(1.0 - ctheta*ctheta)
      polarhalodens=halodens(s,z)*plcon(l)*plgndr1(l,ctheta)
      return
      end


      DOUBLE PRECISION FUNCTION bpser(a,b,x,eps)
C-----------------------------------------------------------------------
C     POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1
C     OR B*X .LE. 0.7.  EPS IS THE TOLERANCE USED.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a0,apb,b0,c,n,sum,t,tol,u,w,z
      INTEGER i,m
C     ..
C     .. External Functions ..
      DOUBLE PRECISION algdiv,betaln,gam1,gamln1
      EXTERNAL algdiv,betaln,gam1,gamln1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dble,dlog,dmax1,dmin1,exp
C     ..
C     .. Executable Statements ..
C
      bpser = 0.0D0
      IF (x.EQ.0.0D0) RETURN
C-----------------------------------------------------------------------
C            COMPUTE THE FACTOR X**A/(A*BETA(A,B))
C-----------------------------------------------------------------------
      a0 = dmin1(a,b)
      IF (a0.LT.1.0D0) GO TO 10
      z = a*dlog(x) - betaln(a,b)
      bpser = exp(z)/a
      GO TO 100

   10 b0 = dmax1(a,b)
      IF (b0.GE.8.0D0) GO TO 90
      IF (b0.GT.1.0D0) GO TO 40
C
C            PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1
C
      bpser = x**a
      IF (bpser.EQ.0.0D0) RETURN
C
      apb = a + b
      IF (apb.GT.1.0D0) GO TO 20
      z = 1.0D0 + gam1(apb)
      GO TO 30

   20 u = dble(a) + dble(b) - 1.D0
      z = (1.0D0+gam1(u))/apb
C
   30 c = (1.0D0+gam1(a))* (1.0D0+gam1(b))/z
      bpser = bpser*c* (b/apb)
      GO TO 100
C
C         PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8
C
   40 u = gamln1(a0)
      m = b0 - 1.0D0
      IF (m.LT.1) GO TO 60
      c = 1.0D0
      DO 50 i = 1,m
          b0 = b0 - 1.0D0
          c = c* (b0/ (a0+b0))
   50 CONTINUE
      u = dlog(c) + u
C
   60 z = a*dlog(x) - u
      b0 = b0 - 1.0D0
      apb = a0 + b0
      IF (apb.GT.1.0D0) GO TO 70
      t = 1.0D0 + gam1(apb)
      GO TO 80

   70 u = dble(a0) + dble(b0) - 1.D0
      t = (1.0D0+gam1(u))/apb
   80 bpser = exp(z)* (a0/a)* (1.0D0+gam1(b0))/t
      GO TO 100
C
C            PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8
C
   90 u = gamln1(a0) + algdiv(a0,b0)
      z = a*dlog(x) - u
      bpser = (a0/a)*exp(z)
  100 IF (bpser.EQ.0.0D0 .OR. a.LE.0.1D0*eps) RETURN
C-----------------------------------------------------------------------
C                     COMPUTE THE SERIES
C-----------------------------------------------------------------------
      sum = 0.0D0
      n = 0.0D0
      c = 1.0D0
      tol = eps/a
  110 n = n + 1.0D0
      c = c* (0.5D0+ (0.5D0-b/n))*x
      w = c/ (a+n)
      sum = sum + w
      IF (abs(w).GT.tol) GO TO 110
      bpser = bpser* (1.0D0+a*sum)
      RETURN

      END


      SUBROUTINE DRJVAL (X, Y, Z, R, RJ, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>>   2001-07-16 DRJVAL Krogh  Change -1.0 to -1.d0.
c>>   1996-03-30 DRJVAL Krogh  Added external statement.
C>>   1995-11-17 DRJVAL Krogh  Converted SFTRAN to Fortran 77.
c>>   1994-10-19 DRJVAL Krogh  Changes to use M77CON
c>>   1994-08-15 DRJVAL WV Snyder JPL use 2-arg min and max for C conv.
C>>   1992-04-17 DRJVAL WV Snyder JPL
C>>   1992-04-13 DRJVAL WV Snyder JPL Give RJ a value even if ierr.ne.0
C>>   1992-04-08 DRJVAL WV Snyder JPL Declare RCX, spell YN correctly.
C>>   1990-12-20 DRJVAL WV Snyder JPL Convert from NSWC for Math 77.
C
C     THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL
C     OF THE THIRD KIND
C
C     RJ(X,Y,Z,R) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                             -1/2     -1/2     -1/2     -1
C                   (3/2)(T+X)    (T+Y)    (T+Z)    (T+R)  DT,
C
C     WHERE X, Y, AND Z ARE NONNEGATIVE, AT MOST ONE OF THEM IS
C     ZERO, AND R IS NONZERO.  IF X OR Y OR Z IS ZERO, THE INTE-
C     GRAL IS COMPLETE.  IF R IS NEGATIVE, THE CAUCHY PRINCIPAL
C     VALUE IS COMPUTED BY USING A PRELIMINARY TRANSFORMATION
C     TO MAKE R POSITIVE; SEE EQUATION (2.22) OF THE SECOND REF-
C     ERENCE BELOW.  WHEN R IS POSITIVE, THE DUPLICATION THEOREM
C     IS ITERATED UNTIL THE VARIABLES ARE NEARLY EQUAL, AND THE
C     FUNCTION IS THEN EXPANDED IN TAYLOR SERIES TO FIFTH ORDER.
C     REFERENCES: B. C. CARLSON AND E. M. NOTIS, ALGORITHMS FOR
C     INCOMPLETE ELLIPTIC INTEGRALS, ACM TRANSACTIONS ON MATHEMA-
C     TICAL SOFTWARE, 7 (1981), 398-403; B. C. CARLSON, COMPUTING
C     ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979),
C     1-16.
C     AUTHORS: B. C. CARLSON AND ELAINE M. NOTIS, AMES LABORATORY-
C     DOE, IOWA STATE UNIVERSITY, AMES, IA 50011, AND R. L. PEXTON,
C     LAWRENCE LIVERMORE NATIONAL LABORATORY, LIVERMORE, CA 94550.
C     AUG. 1, 1979, REVISED SEPT. 1, 1987.
C
C     CHECK VALUES: RJ(2,3,4,5) = 0.14297 57966 71567 53833 23308
C                  RJ(2,3,4,-5) = - 0.12711 23004 29638 83590 80083
C     CHECK BY ADDITION THEOREM: RJ(X,X+Z,X+W,X+P)
C        + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / DSQRT(A)
C        = RJ(0,Z,W,P), WHERE X,Y,Z,W,P ARE POSITIVE AND X * Y
C        = Z * W,  A = P * P * (X+Y+Z+W),  B = P * (P+X) * (P+Y),
C        AND B - A = P * (P-Z) * (P-W).  THE SUM OF THE THIRD AND
C        FOURTH TERMS ON THE LEFT SIDE IS 3 * RC(A,B).
C
C     *****     Formal Arguments     ***********************************
C
C     INPUT ...
C
C     X, Y, Z, AND R ARE THE VARIABLES IN THE INTEGRAL RJ(X,Y,Z,R).
C
C     OUTPUT ...
C
C     RJ IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C     IERR IS THE RETURN ERROR CODE.
C          IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C          IERR = 1  X, Y, OR Z IS NEGATIVE, OR R = 0
C          IERR = 2  X+Y, X+Z, Y+Z, OR ABS(R) IS TOO SMALL.
C          IERR = 3  X, Y, Z, OR ABS(R) IS TOO LARGE.
C
      DOUBLE PRECISION X, Y, Z, R, RJ
      INTEGER IERR
C
C--D replaces "?": ?ERM1, ?ERV1, ?RCVAL, ?RFVLX, ?RJVAL
C
C     *****     External References     ********************************
C
C     DRCVAL COMPUTES RC.  IT CHECKS THE ARGUMENTS, BUT IT'S NOT
C     CALLED FROM WITHIN THE INNER LOOP.  THERE, WE INLINE DRCVAL.
C     DRFVLX COMPUTES RF, BUT ASSUMES ARGUMENTS ARE IN RANGE.
C     DRFVLX IS INSIDE SRFVAL.
C
      EXTERNAL D1MACH
      DOUBLE PRECISION D1MACH
C
C     *****     Local Variables     ************************************
C
      DOUBLE PRECISION A,B,ALFA,BETA,C1,C2,C3,C4,DELTA,EA,EB,EC,E1,E2,E3
      DOUBLE PRECISION EPSLON,ERRTOL,ETOLRC,FIFTH,GAMMA,LAMDA,LOLIM,MU
      DOUBLE PRECISION POWER4,RC,RCX,RF,RN,RNDEV,SIGMA,S1,S2,S3,SN,THIRD
      DOUBLE PRECISION UPLIM,XN,XNDEV,XNROOT,YN,YNDEV,YNROOT,YY
      DOUBLE PRECISION ZN,ZNDEV,ZNROOT,Z1,Z2,Z3,Z4
      PARAMETER (C1 = 3.0d0 / 14.0d0)
      PARAMETER (C2 = 1.0d0 / 3.0d0)
      PARAMETER (C3 = 3.0d0 / 22.0d0)
      PARAMETER (C4 = 3.0d0 / 26.0d0)
      PARAMETER (FIFTH = 1.0d0 / 5.0d0)
      PARAMETER (THIRD = 1.0d0 / 3.0d0)
      PARAMETER (Z1 = 3.0d0 / 10.0d0)
      PARAMETER (Z2 = 1.0d0 / 7.0d0)
      PARAMETER (Z3 = 3.0d0 / 8.0d0)
      PARAMETER (Z4 = 9.0d0 / 22.0d0)
      SAVE ERRTOL, ETOLRC, LOLIM, UPLIM
C
C     MACHINE DEPENDENT PARAMETERS ...
C
C     LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C     LOLIM IS NOT LESS THAN THE CUBE ROOT OF THE VALUE
C     OF LOLIM USED IN THE CODE TO COMPUTE RC, AND
C     UPLIM IS NOT GREATER THAN 0.3 TIMES THE CUBE ROOT OF
C     THE VALUE OF UPLIM USED IN THE CODE TO COMPUTE RC.
C
C     ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. THE
C     RELATIVE ERROR DUE TO TRUNCATION OF THE SERIES FOR RJ
C     IS LESS THAN 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C     ERRTOL / 2 IS USED IN THE CODE TO COMPUTE RC TO MAKE
C     THE TRUNCATION ERROR FOR RC LESS THAN FOR RJ.
C
      DATA LOLIM /-1.0d0/
C
C ----------------------------------------------------------------------
C     WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C     EXPENSE OF ROBUSTNESS.
C ----------------------------------------------------------------------
C
      IF (MIN(X,MIN(Y,Z)) .LT. 0.0d0 .OR. R .EQ. 0.0d0) THEN
         RJ = 0.0d0
         IERR = 1
         CALL DERM1 ('DRJVAL',1,0,
     1      'ONE OF X, Y, or Z is negative, or R is zero','X',X,',')
         CALL DERV1 ('Y',Y,',')
         CALL DERV1 ('Z',Z,',')
         CALL DERV1 ('R',R,'.')
         RETURN
      END IF
      IF (LOLIM .LT. 0.0) THEN
         LOLIM = 1.0001d0 * (5.0d0 * D1MACH(1))**THIRD
         UPLIM = .29999d0 * (D1MACH(2) / 5.0d0)**THIRD
         ERRTOL = (0.28d0 * D1MACH(4))**(1.0d0/6.0d0)
         ETOLRC = 0.5d0 * ERRTOL
      END IF
      IF (MAX(X,MAX(Y,MAX(Z,ABS(R)))) .GT. UPLIM) THEN
         RJ = 0.0d0
         IERR = 3
         CALL DERM1 ('DRJVAL',3,0,'ONE OF X, Y, Z or ABS(R) > UPLIM',
     1      'X',X,',')
         CALL DERV1 ('Y',Y,',')
         CALL DERV1 ('Z',Z,',')
         CALL DERV1 ('R',R,',')
         CALL DERV1 ('UPLIM',UPLIM,'.')
         RETURN
      END IF
      IF (MIN(X+Y,MIN(X+Z,MIN(Y+Z,ABS(R)))) .LT. LOLIM) THEN
         RJ = 0.0d0
         IERR = 2
         CALL DERM1 ('DRJVAL',2,0,
     1      'ONE OF X+Y, X+Z, Y+Z or ABS(R) < LOLIM','X',X,',')
         CALL DERV1 ('Y',Y,',')
         CALL DERV1 ('Z',Z,',')
         CALL DERV1 ('R',R,',')
         CALL DERV1 ('LOLIM',LOLIM,'.')
         RETURN
      END IF
C
      IERR = 0
      IF (R .GT. 0.0d0) THEN
         XN = X
         YN = Y
         ZN = Z
         RN = R
      ELSE
C        ORDER X,Y,Z AND TRANSFORM TO POSITIVE R
         XN = MIN(X,Y)
         YY = MAX(X,Y)
         ZN = MAX(YY,Z)
         YY = MIN(YY,Z)
         YN = MAX(XN,YY)
         XN = MIN(XN,YY)
         A = 1.0d0 / (YN - R)
         B = (ZN - YN) * A * (YN - XN)
         RN = YN + B
         ALFA = XN * ZN / YN
         BETA = R * RN / YN
         CALL DRCVAL (ALFA, BETA, RCX, IERR)
         IF (IERR .NE. 0) THEN
            RJ = 0.0d0
            RETURN
         END IF
      END IF
      SIGMA = 0.0d0
      POWER4 = 1.0d0
C
   20 CONTINUE
         MU = (XN + YN + ZN + RN + RN) * FIFTH
         XNDEV = (MU - XN) / MU
         YNDEV = (MU - YN) / MU
         ZNDEV = (MU - ZN) / MU
         RNDEV = (MU - RN) / MU
         EPSLON = MAX(ABS(XNDEV),MAX(ABS(YNDEV),MAX(ABS(ZNDEV),
     1                ABS(RNDEV))))
         IF (EPSLON .LT. ERRTOL) GO TO 80
         XNROOT = SQRT(XN)
         YNROOT = SQRT(YN)
         ZNROOT = SQRT(ZN)
         LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
         ALFA = RN * (XNROOT + YNROOT + ZNROOT) + XNROOT*YNROOT*ZNROOT
         ALFA = ALFA * ALFA
         BETA = RN * (RN + LAMDA) * (RN + LAMDA)
C        CALL DRCVAL (ALFA, BETA, RC, IERR)
C        IF (IERR .NE. 0) RETURN
C        We use the following instead of calling DRCVAL to avoid the
C        tests for argument range, which we know will succeed.
   40    CONTINUE
            DELTA = (ALFA + BETA + BETA) * THIRD
            SN = (BETA + DELTA) / DELTA - 2.0d0
            IF (ABS(SN) .LT. ETOLRC) GO TO 60
            GAMMA = 2.0 * SQRT(ALFA) * SQRT(BETA) + BETA
            ALFA = (ALFA + GAMMA) * 0.25d0
            BETA = (BETA + GAMMA) * 0.25d0
         GO TO 40
   60    CONTINUE
         RC = (1.0d0 + SN*SN*(Z1 + SN*(Z2 + SN*(Z3+SN*Z4))))/SQRT(DELTA)
         SIGMA = SIGMA + POWER4 * RC
         POWER4 = POWER4 * 0.25d0
         XN = (XN + LAMDA) * 0.25d0
         YN = (YN + LAMDA) * 0.25d0
         ZN = (ZN + LAMDA) * 0.25d0
         RN = (RN + LAMDA) * 0.25d0
      GO TO 20
   80 CONTINUE
C
      E1 = YNDEV * ZNDEV
      EA = XNDEV * (YNDEV + ZNDEV) + E1
      EB = XNDEV * E1
      EC = RNDEV * RNDEV
      E2 = EA - 3.0d0 * EC
      E3 = EB + 2.0d0 * RNDEV * (EA - EC)
      S1 = 1.0d0 + E2 * (-C1 + 0.75d0 * C3 * E2 - 1.5d0 * C4 * E3)
      S2 = EB * (0.5d0 * C2 + RNDEV * (- C3 - C3 + RNDEV * C4))
      S3 = RNDEV * EA * (C2 - RNDEV * C3) - C2 * RNDEV * EC
      RJ = 3.0d0 * SIGMA + POWER4 * (S1 + S2 + S3) / (MU * SQRT(MU))
C
      IF (R .GT. 0.d0) RETURN
      CALL DRFVLX (XN,YN,ZN,RF)
      RJ = A * (B * RJ + 3.0d0 * (RCX - RF))
      RETURN
      END


subroutine rcritpts(rcrit, ncrit, &
   rmt2, rcs2, &
   xp, nbnd, &
   dc2, ncorn, &
   edgp, nedge, &
   runion)

   implicit none

   integer :: ncrit
   integer :: nbnd
   integer :: ncorn
   integer :: nedge
   integer :: iunion
   integer :: i
   integer :: sigma
   !
   real(8) :: dc2(ncorn)
   real(8) :: runion(nbnd + ncorn + nedge + 1)
   real(8) :: rcrit(*)
   real(8) :: rmt2, rcs2
   real(8) :: xp(3, nbnd)
   real(8) :: edgp(3, nedge)
   real(8), parameter :: rtol = 1.0d-10

   ! ================================================================
   ! joint tables of possible critical points........................
   iunion = 1
   runion(1) = rmt2
   do i = 1, nbnd
      if(sigma(xp(1, i), xp(2, i), xp(3, i), xp, nbnd, 1)==1) then
         iunion = iunion + 1
         runion(iunion) = xp(1, i) * xp(1, i) + xp(2, i) * xp(2, i) + xp(3, i) * xp(3, i)
      endif
   enddo
   do i = 1, ncorn
      runion(iunion + i) = dc2(i)
   enddo
   iunion = iunion + ncorn
   do i = 1, nedge
      if(sigma(edgp(1, i), edgp(2, i), edgp(3, i), xp, nbnd, 1)==1)&
         then
         iunion = iunion + 1
         runion(iunion) = &
            edgp(1, i) * edgp(1, i) + edgp(2, i) * edgp(2, i) + edgp(3, i) * edgp(3, i)
      endif
   enddo
   !================================================================
   ! sort the table of possible critical points......................
   ! ----------------------------------------------------------------
   call sort(iunion, runion)
   ! ----------------------------------------------------------------
   !================================================================
   ! obtain list of unique critical points...........................
   ncrit = 1
   rcrit(1) = runion(1)
   do i = 2, iunion
      if(abs(rcrit(ncrit) - runion(i))>rtol .and.&
         (runion(i) - rcs2)<=rtol) then
         ncrit = ncrit + 1
         rcrit(ncrit) = runion(i)
      endif
   enddo
   do i = 1, ncrit
      rcrit(i) = sqrt(rcrit(i))
   enddo
   ! ================================================================
   return
end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine preparation_GS
  use global_variables
  implicit none
  integer :: ix,iy
  real(dp) :: tmp,r,rp,rm

  write(*,'(A)')'===== preparatin_GS =============================================================='
  write(*,'(A)')
  write(*,'(A)')

  allocate(wfn(0:Nx,0:NR), v_ext(0:Nx), v_int(0:Nx,0:NR), v_all(0:Nx,0:NR))
  allocate(rho(0:Nx),rho_n(0:NR))

  write(*,'(A)')'=== preparing initial wave-function ===='
! wfn(0,:) == wfn(Nx,:) == 0
  wfn(:,:) = 0d0

  do ix = 1,Nx-1
  do iy = 1,NR-1
     call random_number(tmp)
     tmp = tmp-0.5d0
     wfn(ix,iy) = tmp
  end do
  end do

  tmp_wfn(:,:) = wfn(:,:)

! Normalize
  tmp = sum(wfn(:,:)**2)*dx*dr
  wfn(:,:)=wfn(:,:)/sqrt(tmp)

  write(*,'(A)')'=== preparing external potential ===='
  v_ext = 0d0
!  do ix=0,Nx
!!     v_ext(ix) = 0.5d0*xn(ix)**2
!     v_ext(ix) = -2d0/sqrt(1d0+xn(ix)**2)
!  end do

  write(*,'(A)')'=== preparing interaction potential ===='
  do iy=0,NR
  do ix=0,Nx
     rp = xn(ix) + 0.5d0*Rn(iy)
     rm = xn(ix) - 0.5d0*Rn(iy)
     r = Rn(iy)
!     v_int(ix,iy) = 0d0 !1d0/sqrt(1d0+r**2)
     v_int(ix,iy) = -1d0/sqrt(1d0+rp**2)-1d0/sqrt(1d0+rm**2)+1d0/sqrt(0.03d0+r**2)
  end do
  end do

  write(*,'(A)')'=== preparing total potential ===='
  do iy=0,NR
  do ix=0,Nx
!     v_all(ix,iy) = v_ext(ix) + v_ext(iy) + v_int(ix,iy)
     v_all(ix,iy) = v_int(ix,iy)
  end do
  end do

  write(*,'(A)')
  write(*,'(A)')
  write(*,'(A)')'===== Complete preparatin_GS ====================================================='

  return
end subroutine preparation_GS


!     Generate .gr3 (e.g. shapiro.gr3)  using bottom slope as a criterion
!     (more criteria than gen_slope_filter).
!     Works for mixed tri/quads
!     Inputs: hgrid.gr3 (projection or lon/lat); consts below
!     Output: slope_filter.gr3

!     ifort -O2 -CB -o gen_slope_filter2 gen_slope_filter2.f90

      implicit real*8(a-h,o-z)
      parameter(mnp=3000000)
      parameter(mne=6000000)
      parameter(mnei=25)
      parameter(rearth_eq=6378206.4d0)
      parameter(rearth_pole=6378206.4d0)
      integer :: i34(mne),elnode(4,mne),nwild(3)
      dimension x(mnp),y(mnp),dp(mnp),area(mne),dldxy(2,3),slope(mne)
      dimension nne(mnp),indel(mnei,mnp),hdif(mnp),hdif_e(mne),rlh(4)
      real*8 :: lframe(3,3),xnd(mnp),ynd(mnp),znd(mnp),xloc(3),yloc(3)

      !Formula: depth=hdif_max*tanh(2*gam/threshold_slope), where gam is
      !slope if slope>slope_min; otherwise =0
      hdif_max=0.5 !max
      pi=3.1415926d0

      print*, 'Input coord system (1: Cartesian; 2: lon/lat):'
      read*, ics

      print*, 'Input ref and min slope:'
      read*, threshold_slope,slope_min

      open(14,file='hgrid.gr3',status='old')
      open(13,file='slope_filter.gr3',status='replace')
      read(14,*)
      read(14,*) ne,np
      if(ne>mne.or.np>mnp) then
        write(*,*)'Increase mne/mnp',mne,mnp,ne,np
        stop
      endif

      do i=1,np
        read(14,*) j,x(i),y(i),dp(i)
        if(ics==2) then
          !global coordi.
          xtmp=x(i)/180*pi
          ytmp=y(i)/180*pi
          xnd(i)=rearth_eq*cos(ytmp)*cos(xtmp)
          ynd(i)=rearth_eq*cos(ytmp)*sin(xtmp)
          znd(i)=rearth_pole*sin(ytmp)
        endif
      enddo !i=1,np

      slope=0 !init
      do i=1,ne
        read(14,*) j,i34(i),elnode(1:i34(i),i)
        !skip shallow elem
        hmax=maxval(dp(elnode(1:i34(i),i)))
        if(hmax<=100) cycle

        do m=1,i34(i)-2 !split into tri
          if(m==1) then
            nwild(1:3)=(/1,2,3/)
          else !quad
            nwild(1:3)=(/1,3,4/)
          endif !m

          n1=elnode(nwild(1),i)
          n2=elnode(nwild(2),i)
          n3=elnode(nwild(3),i)

          if(ics==1) then
            area(i)=signa(x(n1),x(n2),x(n3),y(n1),y(n2),y(n3))
          else !lon/lat
            !Construct local frame with 1,2 as local x-axis, and
            lframe(1,1)=xnd(n2)-xnd(n1)
            lframe(2,1)=ynd(n2)-ynd(n1)
            lframe(3,1)=znd(n2)-znd(n1)
            !(2,1)x(3,1) as local z.
            !Compute local z-axis 1st. [lframe(1:3,1:3): 1st index is
            !component]
            call cross_product(lframe(1,1),lframe(2,1),lframe(3,1), &
                              &xnd(n3)-xnd(n1),ynd(n3)-ynd(n1),znd(n3)-znd(n1), &
                              &lframe(1,3),lframe(2,3),lframe(3,3))

            !y= z \cross x
            call cross_product(lframe(1,3),lframe(2,3),lframe(3,3), &
     &lframe(1,1),lframe(2,1),lframe(3,1),lframe(1,2),lframe(2,2),lframe(3,2))

            !Make unit vectors
            !Compute local coords
            xloc(1)=0; yloc(1:2)=0
            do j=1,3
              rnorm=sqrt(lframe(1,j)**2+lframe(2,j)**2+lframe(3,j)**2)
              if(rnorm==0) stop '0 vector'
              lframe(:,j)=lframe(:,j)/rnorm
              if(j==1) xloc(2)=rnorm
            enddo !j

            xloc(3)=(xnd(n3)-xnd(n1))*lframe(1,1)+(ynd(n3)-ynd(n1))*lframe(2,1)+ &
     &(znd(n3)-znd(n1))*lframe(3,1)
            yloc(3)=(xnd(n3)-xnd(n1))*lframe(1,2)+(ynd(n3)-ynd(n1))*lframe(2,2)+ &
     &(znd(n3)-znd(n1))*lframe(3,2)

            area(i)=signa(xloc(1),xloc(2),xloc(3),yloc(1),yloc(2),yloc(3))
          endif !ics

          if(area(i)<=0) then
            write(*,*)'Negative area at',i
            stop
          endif

          do j=1,3
            nj1=j+1
            nj2=j+2
            if(nj1>3) nj1=nj1-3
            if(nj2>3) nj2=nj2-3
            nd1=elnode(nwild(nj1),i)
            nd2=elnode(nwild(nj2),i)

            if(ics==1) then
              dldxy(1,j)=(y(nd1)-y(nd2))/2/area(i)
              dldxy(2,j)=(x(nd2)-x(nd1))/2/area(i)
            else
              dldxy(1,j)=(yloc(nj1)-yloc(nj2))/2/area(i)
              dldxy(2,j)=(xloc(nj2)-xloc(nj1))/2/area(i)
            endif !ics
          enddo !j
          slx=dot_product(dp(elnode(nwild(1:3),i)),dldxy(1,:))
          sly=dot_product(dp(elnode(nwild(1:3),i)),dldxy(2,:))
          tmp=sqrt(slx**2+sly**2)
          if(tmp>slope_min) slope(i)=max(slope(i),tmp)
        enddo !m
      enddo !i=1,ne

      do i=1,ne
        write(99,*)i,slope(i)
      enddo !i=1,ne

!     Neighborhood
      nne=0
      do i=1,ne
        do j=1,i34(i)
          nd=elnode(j,i)
          nne(nd)=nne(nd)+1
          if(nne(nd)>mnei) then
            write(*,*)'Too many neighbors',nd
            stop
          endif
          indel(nne(nd),nd)=i
        enddo
      enddo

      hdif=0
      do i=1,np
        slopemax=0
        do j=1,nne(i)
          ie=indel(j,i)
          slopemax=max(slopemax,slope(ie))
        enddo !j
        hdif(i)=hdif_max*tanh(2*slopemax/threshold_slope)
        if(hdif(i)<=1.e-2) hdif(i)=0
      enddo !i

      write(13,*)'threshold_slope=',real(threshold_slope),real(slope_min)
      write(13,*)ne,np
      do i=1,np
        write(13,*)i,real(x(i)),real(y(i)),real(hdif(i))
      enddo !i
      do i=1,ne
        write(13,*) i,i34(i),elnode(1:i34(i),i)
      enddo !i

      print*, 'Max bottom slope=',maxval(slope(1:ne))
      print*, 'Min/max filter strength= ',minval(hdif(1:np)),maxval(hdif(1:np))

      stop
      end

      function signa(x1,x2,x3,y1,y2,y3)
!...  Compute signed area formed by pts 1,2,3
      implicit real*8(a-h,o-z)

      signa=((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3))/2

      return
      end

!===============================================================================
!     Cross-product of two vectors: (x1,y1,z1) x (x2,y2,z2) = (x3,y3,z3)
!===============================================================================
      subroutine cross_product(x1,y1,z1,x2,y2,z2,x3,y3,z3)
      implicit real*8(a-h,o-z)
      real(8),intent(in) :: x1,y1,z1,x2,y2,z2
      real(8),intent(out) :: x3,y3,z3

      x3=y1*z2-y2*z1
      y3=x2*z1-x1*z2
      z3=x1*y2-x2*y1

      end subroutine cross_product


      subroutine yzkteg (f,af,g,ag,dr,ap,h,k,nd,np,idim)
c calculation of yk(r)=zk(r)+ r**(k+1) * integral from r to
c   infinity of  f(u) * u**(-k-1)
c zk(r) = r**(-k) * integral from 0 to r of f(u) * u**k

c at the origin f(r)=sum from i=1 to nd of af(i)*r**(ap+i-1)
c dr tabulation points   h exponential step
c np number of tabulation points for f
c idim dimension of the blocks f,g and dr

c at the origin yk=cte*r**(k+1)-developement limit
c the constant for yk lies in ap
c output functions yk and zk lie in f and g, and their
c development coefficients at the origin in af and ag.

c integration from point to point by a 4 points method.
c integral from r to r+h = h*(-f(r-h)+13*f(r)+13*f(r+h)-f(r+h+h))/24

      implicit double precision (a-h,o-z)
      dimension f(251),af(10),g(251),ag(10),dr(251)

c    initialisation and development coefficients of yk
      np= min(np,idim-2)
      b=ap
      ap=0.0d 00
      g(1)=0.0d 00
      g(2)=0.0d 00
      do 15 i=1,nd
         b=b+1.0d 00
         ag(i)=af(i)/(b+k)
         if (af(i).ne.0.0d 00) then
            c=dr(1)**b
            g(1)=g(1)+ag(i)*c
            g(2)=g(2)+ag(i)*(dr(2)**b)
            af(i)=(k+k+1)*ag(i)/(b-k-1)
            ap=ap+af(i)*c
         endif
 15   continue
      do i=1,np
         f(i)=f(i)*dr(i)
      enddo
      np1=np+1
      f(np1)=0.0d 00
      f(np1+1)=0.0d 00

c     calcualation of zk
      eh= exp(h)
      e=eh**(-k)
      b=h/2.4d+01
      c=1.3d+01*b
      ee=e*e*b
      b=b/e
      do i=3,np1
         g(i)=g(i-1)*e+(c*(f(i)+f(i-1)*e)-(f(i-2)*ee+f(i+1)*b))
      enddo
c     calcualation of yk
      f(np)=g(np)
      do i=np1,idim
         f(i)=f(i-1)*e
      enddo
      i=k+k+1
      b=i*b*eh
      ee=i*ee/(eh*eh)
      e=e/eh
      c=i*c
      do i=np-1,2,-1
         f(i)=f(i+1)*e+(c*(g(i)+g(i+1)*e)-(g(i+2)*ee+g(i-1)*b))
      enddo
      ee=e*e
      c=8.0d00*c/1.3d+01
      f(1)=f(3)*ee+c*(g(3)*ee+4.0d00*e*g(2)+g(1))
      ap=(ap+f(1))/(dr(1)**(k+1))
      return
      end


      subroutine run_00ii(k,l,i1,i2,DetGr,f,Gtwiddle,Gtt,
     . Shat3,Shat4,S00ii,Shat4zz,N0)
      implicit none
C--   Fixes D00ii using 5.47
C     knowing D0000,Dii,D00i with correction of order delta*Diiii
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,n,m,i1,i2,np
      parameter(np=3)
      double precision DetGr,Gtwiddle(np,np),Gtt(np,np,np,np),
     . f(np)
      double complex S00ii(z2max,-2:0),Shat4zz(np,z1max,-2:0),
     . Shat3(np,z2max,-2:0),Shat4(np,z3max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit
     . +Gtt(k,n,l,m)*(f(n)*Shat3(m,z2(i1,i2),ep)
     . +2d0*(delta(n,i1)*Shat4zz(m,i2,ep)+delta(n,i2)*Shat4zz(m,i1,ep))
     . -f(n)*f(m)*Dv(dii(z2(i1,i2))+N0,ep)
     . -2d0*(f(n)*delta(m,i1)+f(m)*delta(n,i1))*Dv(dzzi(i2)+N0,ep)
     . -2d0*(f(n)*delta(m,i2)+f(m)*delta(n,i2))*Dv(dzzi(i1)+N0,ep)
     . -4d0*(delta(n,i1)*delta(m,i2)+delta(n,i2)*delta(m,i1))
     . *Dv(dd0000+N0,ep))
      enddo
      enddo
      pole=czip
      if (ep .gt. -2)
     .  pole=-4d0*Gtwiddle(k,l)*Dv(dzzii(z2(i1,i2))+N0,ep-1)

      Dv(dzzii(z2(i1,i2))+N0,ep)=
     . -(pole
     . +DetGr*Dv(diiii(z4(k,l,i1,i2))+N0,ep)
     . -Gtwiddle(k,l)*S00ii(z2(i1,i2),ep)
     . -Gtwiddle(1,l)*Shat4(1,z3(k,i1,i2),ep)
     . -Gtwiddle(2,l)*Shat4(2,z3(k,i1,i2),ep)
     . -Gtwiddle(3,l)*Shat4(3,z3(k,i1,i2),ep)
     . +Gtwiddle(k,l)
     . *(Shat4(1,z3(1,i1,i2),ep)
     .  +Shat4(2,z3(2,i1,i2),ep)
     .  +Shat4(3,z3(3,i1,i2),ep))
     . +bit)/(12d0*Gtwiddle(k,l))

      enddo

      return
      end


      subroutine fpcsin(a,b,par,sia,coa,sib,cob,ress,resc)
c  fpcsin calculates the integrals ress=integral((b-x)**3*sin(par*x))
c  and resc=integral((b-x)**3*cos(par*x)) over the interval (a,b),
c  given sia=sin(par*a),coa=cos(par*a),sib=sin(par*b) and cob=cos(par*b)
c  ..
c  ..scalar arguments..
      real*8 a,b,par,sia,coa,sib,cob,ress,resc
c  ..local scalars..
      integer i,j
      real*8 ab,ab4,ai,alfa,beta,b2,b4,eps,fac,f1,f2,one,quart,six,
     * three,two
c  ..function references..
      real*8 abs
c  ..
      one = 0.1e+01
      two = 0.2e+01
      three = 0.3e+01
      six = 0.6e+01
      quart = 0.25e+0
      eps = 0.1e-09
      ab = b-a
      ab4 = ab**4
      alfa = ab*par
c the way of calculating the integrals ress and resc depends on
c the value of alfa = (b-a)*par.
      if(abs(alfa).le.one) go to 100
c integration by parts.
      beta = one/alfa
      b2 = beta**2
      b4 = six*b2**2
      f1 = three*b2*(one-two*b2)
      f2 = beta*(one-six*b2)
      ress = ab4*(coa*f2+sia*f1+sib*b4)
      resc = ab4*(coa*f1-sia*f2+cob*b4)
      go to 400
c ress and resc are found by evaluating a series expansion.
 100  fac = quart
      f1 = fac
      f2 = 0.
      i = 4
      do 200 j=1,5
        i = i+1
        ai = i
        fac = fac*alfa/ai
        f2 = f2+fac
        if(abs(fac).le.eps) go to 300
        i = i+1
        ai = i
        fac = -fac*alfa/ai
        f1 = f1+fac
        if(abs(fac).le.eps) go to 300
 200  continue
 300  ress = ab4*(coa*f2+sia*f1)
      resc = ab4*(coa*f1-sia*f2)
 400  return
      end


*     MB04ZD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDQG, LDU
      PARAMETER        ( LDA = NMAX, LDQG = NMAX, LDU = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = ( NMAX+NMAX )*( NMAX+NMAX+1 ) )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      INTEGER          I, INFO, IJ, J, JI, N, POS, WPOS
      CHARACTER*1      COMPU
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), QG(LDQG,NMAX+1),
     $                 U(LDU,NMAX)
*     .. External Subroutines ..
      EXTERNAL         DCOPY, DGEMM, DSYMV, MB04ZD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, COMPU
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99998 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J),    J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(I,J),   I = J,N ), J = 1,N )
*        Square-reduce by symplectic orthogonal similarity.
         CALL MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99997 ) INFO
         ELSE
*           Show the square-reduced Hamiltonian.
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99994 )  ( A(I,J),    J = 1,N ),
     $            ( QG(J,I+1), J = 1,I-1 ), ( QG(I,J+1), J = I,N )
10          CONTINUE
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99994 ) ( QG(I,J), J = 1,I-1 ),
     $               ( QG(J,I), J = I,N ), ( -A(J,I), J = 1,N )
20          CONTINUE
*           Show the square of H.
            WRITE ( NOUT, FMT = 99995 )
            WPOS = ( NMAX+NMAX )*( NMAX+NMAX )
*                                                    T
*           Compute N11 = A*A + G*Q and set N22 = N11 .
            CALL DGEMM( 'N', 'N', N, N, N, ONE, A, LDA, A, LDA, ZERO,
     $                  DWORK, N+N )
            DO 30 I = 1, N
               CALL DCOPY( N-I+1, QG(I,I), 1, DWORK(WPOS+I), 1 )
               CALL DCOPY( I-1, QG(I,1), LDQG, DWORK(WPOS+1), 1 )
               CALL DSYMV( 'U', N, ONE, QG(1,2), LDQG, DWORK(WPOS+1), 1,
     $                     ONE, DWORK((I-1)*(N+N)+1), 1 )
               POS = N*( N+N ) + N + I
               CALL DCOPY( N, DWORK((I-1)*(N+N)+1), 1, DWORK(POS), N+N )
30          CONTINUE
            DO 40 I = 1, N
               CALL DSYMV( 'U', N, -ONE, QG(1,2), LDQG, A(I,1), LDA,
     $                     ZERO, DWORK((N+I-1)*(N+N)+1), 1 )
               CALL DSYMV( 'L', N, ONE, QG, LDQG, A(1,I), 1, ZERO,
     $                     DWORK((I-1)*(N+N)+N+1), 1 )
40          CONTINUE
            DO 60 J = 1, N
               DO 50 I = J, N
                  IJ = ( N+J-1 )*( N+N ) + I
                  JI = ( N+I-1 )*( N+N ) + J
                  DWORK(IJ) =  DWORK(IJ) - DWORK(JI)
                  DWORK(JI) = -DWORK(IJ)
                  IJ = N + I + ( J-1 )*( N+N )
                  JI = N + J + ( I-1 )*( N+N )
                  DWORK(IJ) =  DWORK(IJ) - DWORK(JI)
                  DWORK(JI) = -DWORK(IJ)
50             CONTINUE
60          CONTINUE
            DO 70 I = 1, N+N
               WRITE ( NOUT, FMT = 99994 )
     $               ( DWORK(I+(J-1)*(N+N) ), J = 1,N+N )
70          CONTINUE
         ENDIF
      END IF
      STOP
*
99999 FORMAT (' MB04ZD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' N is out of range.',/' N = ',I5)
99997 FORMAT (' INFO on exit from MB04ZD = ',I2)
99996 FORMAT (/' The square-reduced Hamiltonian is ')
99995 FORMAT (/' The square of the square-reduced Hamiltonian is ')
99994 FORMAT (1X,8(F10.4))
      END


*DECK DPPQAD
      SUBROUTINE DPPQAD (LDC, C, XI, LXI, K, X1, X2, PQUAD)
C***BEGIN PROLOGUE  DPPQAD
C***PURPOSE  Compute the integral on (X1,X2) of a K-th order B-spline
C            using the piecewise polynomial (PP) representation.
C***LIBRARY   SLATEC
C***CATEGORY  H2A2A1, E3, K6
C***TYPE      DOUBLE PRECISION (PPQAD-S, DPPQAD-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract    **** a double precision routine ****
C         DPPQAD computes the integral on (X1,X2) of a K-th order
C         B-spline using the piecewise polynomial representation
C         (C,XI,LXI,K).  Here the Taylor expansion about the left
C         end point XI(J) of the J-th interval is integrated and
C         evaluated on subintervals of (X1,X2) which are formed by
C         included break points.  Integration outside (XI(1),XI(LXI+1))
C         is permitted.
C
C     Description of Arguments
C         Input      C,XI,X1,X2 are double precision
C           LDC    - leading dimension of matrix C, LDC .GE. K
C           C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI
C           XI(*)  - break point array of length LXI+1
C           LXI    - number of polynomial pieces
C           K      - order of B-spline, K .GE. 1
C           X1,X2  - end points of quadrature interval, normally in
C                    XI(1) .LE. X .LE. XI(LXI+1)
C
C         Output     PQUAD is double precision
C           PQUAD  - integral of the PP representation over (X1,X2)
C
C     Error Conditions
C         Improper input is a fatal error
C
C***REFERENCES  D. E. Amos, Quadrature subroutines for splines and
C                 B-splines, Report SAND79-1825, Sandia Laboratories,
C                 December 1979.
C***ROUTINES CALLED  DINTRV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPQAD
C
      INTEGER I, II, IL, ILO, IL1, IL2, IM, K, LDC, LEFT, LXI, MF1, MF2
      DOUBLE PRECISION A,AA,BB,C,DX,FLK,PQUAD,Q,S,SS,TA,TB,X,XI,X1,X2
      DIMENSION XI(*), C(LDC,*), SS(2)
C
C***FIRST EXECUTABLE STATEMENT  DPPQAD
      PQUAD = 0.0D0
      IF(K.LT.1) GO TO 100
      IF(LXI.LT.1) GO TO 105
      IF(LDC.LT.K) GO TO 110
      AA = MIN(X1,X2)
      BB = MAX(X1,X2)
      IF (AA.EQ.BB) RETURN
      ILO = 1
      CALL DINTRV(XI, LXI, AA, ILO, IL1, MF1)
      CALL DINTRV(XI, LXI, BB, ILO, IL2, MF2)
      Q = 0.0D0
      DO 40 LEFT=IL1,IL2
        TA = XI(LEFT)
        A = MAX(AA,TA)
        IF (LEFT.EQ.1) A = AA
        TB = BB
        IF (LEFT.LT.LXI) TB = XI(LEFT+1)
        X = MIN(BB,TB)
        DO 30 II=1,2
          SS(II) = 0.0D0
          DX = X - XI(LEFT)
          IF (DX.EQ.0.0D0) GO TO 20
          S = C(K,LEFT)
          FLK = K
          IM = K - 1
          IL = IM
          DO 10 I=1,IL
            S = S*DX/FLK + C(IM,LEFT)
            IM = IM - 1
            FLK = FLK - 1.0D0
   10     CONTINUE
          SS(II) = S*DX
   20     CONTINUE
          X = A
   30   CONTINUE
        Q = Q + (SS(1)-SS(2))
   40 CONTINUE
      IF (X1.GT.X2) Q = -Q
      PQUAD = Q
      RETURN
C
C
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPQAD', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPQAD', 'LXI DOES NOT SATISFY LXI.GE.1',
     +   2, 1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPQAD', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
      END


      SUBROUTINE PKTRBS (IOPT)
C
C     BASIC BENDING TRIANGLE ELEMENT ROUTINE
C
C     THIS ROUTINE DOES SUB-CALCULATIONS FOR TRI OR QUAD PLATES IN PLA4
C
C     CALLS FROM THIS ROUTINE ARE MADE TO
C          MAT    - MATERIAL DATA ROUTINE
C
C     PLAMAT - ROTATES AND RETURNS GP MATRIX
C          TRANSD - DOUBLE PRECISION TRANSFORMATION SUPPLIER
C          INVERD - DOUBLE PRECISION INVERSE ROUTINE
C          GMMATD - DOUBLE PRECISION MATRIX MULTIPLY AND TRANSPOSE
C          MESAGE - ERROR MESSAGE WRITER
C
C     IOPT = 1   IMPLIES COMPUTE ONLY THE NINE (3X3)MATRICES
C                WHICH FORM THE 9X9 K SUPER U - MATRIX.
C     IOPT = 2   SAME AS IOPT = 1,BUT SAVE H-INVERSE AND S
C
C     ECPT LIST FOR BASIC BENDING TRIANGLE          NAME IN
C                                                   THIS
C     ECPT                                          ROUTINE   TYPE
C     ------------------------------------        -------------------
C     ECPT( 1) = ELEMENT ID                         NECPT(1)  INTEGER
C     ECPT( 2) = GRID POINT A                       NGRID(1)  INTEGER
C     ECPT( 3) = GRID POINT B                       NGRID(2)  INTEGER
C     ECPT( 4) = GRID POINT C                       NGRID(3)  INTEGER
C     ECPT( 5) = THETA = ANGLE OF MATERIAL          ANGLE     REAL
C     ECPT( 6) = MATERIAL ID 1                      MATID1    INTEGER
C     ECPT( 7) = I = MOMENT OF INERTIA              EYE       REAL
C     ECPT( 8) = MATERIAL ID 2                      MATID2    INTEGER
C     ECPT( 9) = T2                                 T2        REAL
C     ECPT(10) = NON-STRUCTURAL-MASS                FMU       REAL
C     ECPT(11) = Z1                                 Z11       REAL
C     ECPT(12) = Z2                                 Z22       REAL
C     ECPT(13) = COORD. SYSTEM ID 1                 NECPT(13) INTEGER
C     ECPT(14) = X1                                 X1        REAL
C     ECPT(15) = Y1                                 Y1        REAL
C     ECPT(16) = Z1                                 Z1        REAL
C     ECPT(17) = COORD. SYSTEM ID 2                 NECPT(17) INTEGER
C     ECPT(18) = X2                                 X2        REAL
C     ECPT(19) = Y2                                 Y2        REAL
C     ECPT(20) = Z2                                 Z2        REAL
C     ECPT(21) = COORD. SYSTEM ID 3                 NECPT(21) INTEGER
C     ECPT(22) = X3                                 X3        REAL
C     ECPT(23) = Y3                                 Y3        REAL
C     ECPT(24) = Z3                                 Z3        REAL
C     ECPT(25) = ELEMENT TEMPERATURE                ELTEMP    REAL
C
      INTEGER          SUBSCA,SUBSCB
      DOUBLE PRECISION A,E,XSUBB,TEMP,XSUBC,D,YSUBC,XCYC,XCSQ,DETERM,
     1                 YCSQ,XBSQ,G2X2,TITE,TJTE,S,TI,J2X2,AREA,G,XBAR,
     2                 YBAR,PX2,PY2,PXY2,XBAR3,YBAR2,YBAR3,PROD9,TEMP9
      DIMENSION        D(9),G2X2(4),J2X2(4),S(18),ECPT(1),G(9),TJTE(18),
     1                 TITE(18),TI(9)
      COMMON /PLA42C/  NPVT,DUM1(148),NOGO
      COMMON /MATIN /  MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/  G11,G12,G13,G22,G23,G33,RHO,ALPHA1,ALPHA2,ALP12,
     1                 T SUB 0, G SUB E, SIGTEN, SIGCOM, SIGSHE,
     2                 G2X211, G2X212, G2X222
C
C     ECPT BLOCK
      COMMON /PLA4ES/  NECPT(1),NGRID(3),ANGLE,MATID1,EYE,MATID2,T2,FMU,
     1                 Z11,Z22,DUMMY1,X1,Y1,Z1,DUMMY2,X2,Y2,Z2,DUMMY3,
     2                 X3,Y3,Z3,DUMB(76)
      COMMON /PLA42D/  A(225),PROD9(9),TEMP9(9),XSUBB,XSUBC,YSUBC,E(18),
     1                 TEMP,XBAR,AREA,XCSQ,YBAR2,YCSQ,YBAR,XBSQ,PX2,
     2                 XCYC,PY2,PXY2,XBAR3,YBAR3,DETERM,NSIZED,
     3                 DUMDUM(4),NPIVOT,THETA,NSUBC,ISING,SUBSCA,SUBSCB,
     4                 NBEGIN,DUMMY(30)
      EQUIVALENCE      (D(1),G(1),A(79)),(ECPT(1),NECPT(1)),
     1                 (G2X2(1),A(88)),(TJTE(1),A(100)),
     2                 (TITE(1),S(1),A(82)),(J2X2(1),A(92)),
     3                 (TI(1),A(118))
C
C
      MATID  = MATID1
      INFLAG = -1
C
      CALL PLAMAT
C
C     FILL G-MATRIX WITH OUTPUT FROM MAT ROUTINE
C
      G(1) = G11
      G(2) = G12
      G(3) = G13
      G(4) = G12
      G(5) = G22
      G(6) = G23
      G(7) = G13
      G(8) = G23
      G(9) = G33
C
C     COMPUTATION OF D = I.G-MATRIX (EYE IS INPUT FROM THE ECPT)
C
      DO 90 I = 1,9
   90 D(I) = G(I)*DBLE(EYE)
C
      AREA = XSUBB*YSUBC/2.0D0
      XBAR =(XSUBB + XSUBC)/3.0D0
      YBAR = YSUBC/3.0D0
C
      XCSQ  = XSUBC**2
      YCSQ  = YSUBC**2
      XBSQ  = XSUBB**2
      XCYC  = XSUBC*YSUBC
      PX2   = (XBSQ + XSUBB*XSUBC + XCSQ)/6.0D0
      PY2   = YCSQ/6.0D0
      PXY2  = YSUBC*(XSUBB + 2.0D0*XSUBC)/12.0D0
      XBAR3 = 3.0D0*XBAR
      YBAR3 = 3.0D0*YBAR
      YBAR2 = 2.0D0*YBAR
C
C                 X
C     FILL THE  (K ) MATRIX STORING IN  A(1) THRU A(36)
C
      A( 1) = D( 1)
      A( 2) = D( 3)
      A( 3) = D( 2)
      A( 4) = D( 1)*XBAR3
      A( 5) = D( 2)*XBAR + YBAR2*D(3)
      A( 6) = D( 2)*YBAR3
      A( 7) = A( 2)
      A( 8) = D( 9)
      A( 9) = D( 6)
      A(10) = D( 3)*XBAR3
      A(11) = D( 6)*XBAR + YBAR2*D(9)
      A(12) = D( 6)*YBAR3
      A(13) = A( 3)
      A(14) = A( 9)
      A(15) = D( 5)
      A(16) = D( 2)*XBAR3
      A(17) = D( 5)*XBAR + YBAR2*D(6)
      A(18) = D( 5)*YBAR3
      A(19) = A( 4)
      A(20) = A(10)
      A(21) = A(16)
      A(22) = D( 1)*9.0D0*PX2
      A(23) = D( 2)*3.0D0*PX2 + 6.0D0*PXY2*D(3)
      A(24) = D( 2)*9.0D0*PXY2
      A(25) = A( 5)
      A(26) = A(11)
      A(27) = A(17)
      A(28) = A(23)
      A(29) = D( 5)*PX2 + 4.0D0*PXY2*D(6) + 4.0D0*PY2*D(9)
      A(30) = D( 5)*3.0D0*PXY2 + 6.0D0*PY2*D(6)
      A(31) = A( 6)
      A(32) = A(12)
      A(33) = A(18)
      A(34) = A(24)
      A(35) = A(30)
      A(36) = D( 5)*9.0D0*PY2
      TEMP  = 4.0D0*AREA
      DO 70 I = 1,36
   70 A(I)  = A(I)*TEMP
C
C     F1LL  (HBAR) MATRIX STORING AT A(37) THRU A(72)
C
      DO 130 I = 37,72
  130 A(I) = 0.0D0
C
      A(37) = XBSQ
      A(40) = XBSQ*XSUBB
      A(44) = XSUBB
      A(49) =-2.0D0*XSUBB
      A(52) =-3.0D0*XBSQ
      A(55) = XCSQ
      A(56) = XCYC
      A(57) = YCSQ
      A(58) = XCSQ*XSUBC
      A(59) = YCSQ*XSUBC
      A(60) = YCSQ*YSUBC
      A(62) = XSUBC
      A(63) = YSUBC*2.0D0
      A(65) = XCYC *2.0D0
      A(66) = YCSQ *3.0D0
      A(67) =-2.0D0*XSUBC
      A(68) =-YSUBC
      A(70) =-3.0D0*XCSQ
      A(71) =-YCSQ
C
      IF (T2 .EQ. 0.0E0) GO TO 500
C
C     ALL OF THE FOLLOWING OPERATIONS THROUGH STATEMENT LABEL 500
C     ARE NECESSARY IF T2 IS NON-ZERO.
C
C     GET THE G2X2 MATRIX
C
      MATID  = MATID2
      INFLAG = 3
      CALL MAT (ECPT(1))
      IF (G2X211.EQ.0.0 .AND. G2X212.EQ.0.0 .AND. G2X222.EQ.0.0)
     1    GO TO 500
      G2X2(1) = G2X211*T2
      G2X2(2) = G2X212*T2
      G2X2(3) = G2X212*T2
      G2X2(4) = G2X222*T2
C
      DETERM  = G2X2(1)*G2X2(4) - G2X2(3)*G2X2(2)
      J2X2(1) = G2X2(4)/DETERM
      J2X2(2) =-G2X2(2)/DETERM
      J2X2(3) =-G2X2(3)/DETERM
      J2X2(4) = G2X2(1)/DETERM
C
C     (H  ) IS PARTITIONED INTO A LEFT AND RIGHT PORTION AND ONLY THE
C       YQ  RIGHT PORTION IS COMPUTED AND USED AS A  (2X3). THE LEFT
C           2X3 PORTION IS NULL.  THE RIGHT PORTION WILL BE STORED AT
C           A(73)...A(78) UNTIL NOT NEEDED ANY FURTHER.
C
      TEMP  =  2.0D0*D(2) + 4.0D0*D(9)
      A(73) = -6.0D0*(J2X2(1)*D(1) + J2X2(2)*D(3))
      A(74) = -J2X2(1)*TEMP + 6.0D0*J2X2(2)*D(6)
      A(75) = -6.0D0*(J2X2(1)*D(6) + J2X2(2)*D(5))
      A(76) = -6.0D0*(J2X2(2)*D(1) + J2X2(4)*D(3))
      A(77) = -J2X2(2)*TEMP + 6.0D0*J2X2(4)*D(6)
      A(78) = -6.0D0*(J2X2(2)*D(6) + J2X2(4)*D(5))
C
C     THE ABOVE 6 ELEMENTS NOW REPRESENT THE (H  ) MATRIX (2X3)
C                                              YQ
C
C     NOW FORMING  PRODUCT (G2X2)(H  ) AND STORING AS AN INTERMEDIATE
C     STEP.                        YQ
C
      CALL GMMATD (G2X2(1),2,2,0, A(73),2,3,0, A(79))
C
C                                                               Y
C     WITH LAST PRODUCT  FORM  LOWER RIGHT 3 X 3 PARTITION OF (K )
C
C              Y                   T
C     THUS   (K ) PARTITION = (H  ) (LAST PRODUCT)   STORE AT A(85)
C                               YQ
C
      CALL GMMATD (A(73),2,3,1, A(79),2,3,0, A(85))
C
C                                                     X
C     NOW ADD THE 9 ELEMENTS OF THIS 3X3 PORTION TO (K )
C     PER STEP 5 PAGE -16- MS-17                            Y
C     MULTIPLY IN AREA AT SAME TIME WHICH WAS LEFT OUT OF (K ) ABOVE.
C
      DO 60 I = 1,3
      A(I+21) = A(I+21) + A(I+84)*AREA
      A(I+27) = A(I+27) + A(I+87)*AREA
   60 A(I+33) = A(I+33) + A(I+90)*AREA
C
C     ADD TO 6 OF THE (HBAR) ELEMENTS THE RESULT OF (H  )(H  )
C                                                    UY   YQ
C     THE PRODUCT IS FORMED DIRECTLY IN THE ADDITION PROCESS BELOW.
C     NO (H  ) MATRIX IS ACTUALLY COMPUTED DIRECTLY.
C          UY
C
C     THE FOLLOWING IS THEN PER STEPS 6 AND 7 PAGE -16- MS-17.
C
      DO 75 I = 1,3
      A(I+39) = A(I+39) + XSUBB*A(I+72)
   75 A(I+57) = A(I+57) + XSUBC*A(I+72) + YSUBC*A(I+75)
C
C     THIS ENDS ADDED COMPUTATION FOR CASE OF T2 NOT ZERO
C
  500 CONTINUE
C
C     AT THIS POINT INVERT  (H) WHICH IS STORED AT A(37) THRU A(72)
C     STORE INVERSE BACK IN A(37) THRU A(72)
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
C
      ISING = -1
      CALL INVERD (6,A(37),6,A(73),0,DETERM,ISING,A(79))
C
C     CHECK TO SEE IF H WAS SINGULAR
C
      IF (ISING .NE. 2) GO TO 440
C
C     ISING = 2 IMPLIES SINGULAR MATRIX THUS ERROR CONDITION.
C
      CALL MESAGE (30,33,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C              Q   -1
C 440 FORM   (K )(H  )  AND STORE AT  A(73) THRU A(108)
C
C                 X                     Q
C     NOTE THAT (K ) AT THIS POINT IS (K )
C
  440 CALL GMMATD (A(1),6,6,0, A(37),6,6,0, A(73))
C
C                    -1 T
C     FORM(K  ) = (H  ) (LAST PRODUCT) STORE AT A(109) THRU A(144)
C            II
C
      CALL GMMATD (A(37),6,6,1, A(73),6,6,0, A(109))
C
C     FILL S-MATRIX EQUIVALENCED TO A(82)  (S IS 6X3)
C
      IF (IOPT .NE. 2) GO TO 700
C
C     SAVE H-INVERSE TO BE USED BY TRIANGULAR PLATE ROUTINE.
C
      DO 710 I = 37,72
  710 A(I+108) = A(I)
C
  700 S( 1) = 1.0D0
      S( 2) = 0.0D0
      S( 3) =-XSUBB
      S( 4) = 0.0D0
      S( 5) = 1.0D0
      S( 6) = 0.0D0
      S( 7) = 0.0D0
      S( 8) = 0.0D0
      S( 9) = 1.0D0
      S(10) = 1.0D0
      S(11) = YSUBC
      S(12) =-XSUBC
      S(13) = 0.0D0
      S(14) = 1.0D0
      S(15) = 0.0D0
      S(16) = 0.0D0
      S(17) = 0.0D0
      S(18) = 1.0D0
C
C                     T
C     FORM   K   = K   = -K   S  STORING AT A(46)   (K   IS 6X3)
C             IA    AI     II                         IA
C
       CALL GMMATD (A(109),6,6,0, S(1),6,3,0, A(46))
C
C     THIS PRODUCT IS MULTIPLIED BY SCALER -1 BELOW.
C
C                    T
C          (K  ) = (S )(-K  )
C            AA           IA
C
C     NOTE K    HAS NOT BEEN MULTIPLIED ABOVE BY -1, THUS IGNORE MINUS
C           IA                                                   HERE.
C
      CALL GMMATD (S(1),6,3,1, A(46),6,3,0, A(1))
C
C     NOW MULTIPLY  K   BY SCALER (-1)
C                    IA
C
      DO 190 I = 46,63
  190 A(I) = -A(I)
C
C     AT THIS POINT, STORED BY ROWS ARE
C
C        K     (6X6) AT A(109) THRU A(144)
C         II
C
C        K     (6,3) AT  A(46) THRU A(63)
C         IA
C
C        K     (3X3) AT A(1) THRU A(9)
C         AA
C
C     ARRANGE NINE 3X3 MATRICES OF K SUPER U
C
      A( I) = A(I+18)
      A(10) = A( 46)
      A(11) = A( 49)
      A(12) = A( 52)
      A(13) = A( 47)
      A(14) = A( 50)
      A(15) = A( 53)
      A(16) = A( 48)
      A(17) = A( 51)
      A(18) = A( 54)
      A(19) = A( 55)
      A(20) = A( 58)
      A(21) = A( 61)
      A(22) = A( 56)
      A(23) = A( 59)
      A(24) = A( 62)
      A(25) = A( 57)
      A(26) = A( 60)
      A(27) = A( 63)
      A(37) = A(109)
      A(38) = A(110)
      A(39) = A(111)
      A(40) = A(115)
      A(41) = A(116)
      A(42) = A(117)
      A(43) = A(121)
      A(44) = A(122)
      A(45) = A(123)
      A(46) = A(112)
      A(47) = A(113)
      A(48) = A(114)
      A(49) = A(118)
      A(50) = A(119)
      A(51) = A(120)
      A(52) = A(124)
      A(53) = A(125)
      A(54) = A(126)
      A(64) = A(127)
      A(65) = A(128)
      A(66) = A(129)
      A(67) = A(133)
      A(68) = A(134)
      A(69) = A(135)
      A(70) = A(139)
      A(71) = A(140)
      A(72) = A(141)
      A(73) = A(130)
      A(74) = A(131)
      A(75) = A(132)
      A(76) = A(136)
      A(77) = A(137)
      A(78) = A(138)
      A(79) = A(142)
      A(80) = A(143)
      A(81) = A(144)
      RETURN
      END


!>
!! @file
!!
!!  PLASMA is a software package provided by:
!!  University of Tennessee,  US,
!!  University of Manchester, UK
!!
!! @precisions mixed zc -> ds
!!
!! @brief Tests Cholesky factorization-based iterative refinement
!!  routine for solution of linear system A*X=B, where A is
!!  n-by-n Hermitian positive definite matrix, and X, B are n-by-nrhs
!!  matrices

      program test_zcposv

      use, intrinsic :: iso_fortran_env
      use            :: iso_c_binding
      use            :: omp_lib
      use            :: plasma

      implicit none

      ! Precisions
      integer, parameter :: sp = c_float
      integer, parameter :: dp = c_double

      ! Matrices A, X, B
      complex(dp), allocatable :: A(:,:), Aref(:,:), X(:,:), B(:,:)

      ! Matrix dimensions
      integer :: n = 1000, nrhs = 1, lda, ldb, ldx

      ! PLASMA variables
      integer :: nb = 120
      integer :: uploPlasma = PlasmaLower
      integer :: i, iter, info

      ! LAPACK variables
      integer :: iSeed(8) = [3476, 1940, 2069, 1681, 2151, 822, 3982, 757]

      complex(dp) :: zone = 1.0, zmone = -1.0

      real(dp), allocatable :: work(:)
      real(dp)              :: Anorm, Xnorm, Rnorm, relerr

      ! Test variables
      ! character(len=32) :: frmt ="(10(3X,F7.3,SP,F7.3,'i'))"
      real(dp)          :: tol  = 0.0d+0

      ! Performance variables
      real(dp) :: tstart = 0.0, tstop = 0.0, telapsed = 0.0d+0

      ! External functions
      real(dp), external :: dlamch
      real(dp), external :: zlange

      lda = max(1,n)
      ldb = lda
      ldx = lda

      tol = 50.0d+0 * dlamch('E')

      ! Allocate matrices
      allocate(A(lda,n), Aref(lda,n), X(ldx,nrhs), B(ldb,nrhs), work(n))

      !=================================================================
      ! Generate and initialize random matrices A and B
      !=================================================================

      ! Generate Hermitian positive definite matrix A
      call zlarnv(1, iSeed(1:4), lda*n, A)

      A = 0.5 * ( A+conjg(transpose(A)) )
      ! A = A * conjg(transpose(A))

      do i = 1, n
        A(i,i) = A(i,i) + n
      end do

      ! @test Print out matrix A
!       print *, "Random Hermitian positive definite matrix A:"
!       do i = 1, lda
!         print frmt, A(i,:)
!       end do
!       print *, ""

      ! Save initial matrix A into Aref
      Aref = A

      ! Generate random matrix B
      call zlarnv(1, iSeed(5:8), ldb*nrhs, B)

      ! @test Print out matrix B
!       print *, "Random matrix B:"
!       do i = 1, ldb
!         print frmt, B(i,:)
!       end do
!       print *, ""

      ! Initialize solution matrix X
      X = 0.0d+0

      !=================================================================
      ! Initialize PLASMA
      !=================================================================
      call plasma_init(info)

      call plasma_set(PlasmaNb, nb, info)

      !=================================================================
      ! Solve linear system A*X=B
      !=================================================================
      tstart   = omp_get_wtime()

      call plasma_zcposv(uploPlasma, n, nrhs, A, lda, B, ldb, X, ldx, &
                         iter, info)

      tstop    = omp_get_wtime()
      telapsed = tstop - tstart

      ! @test Print out solution matrix X
!       print *, "Solution matrix X:"
!       do i = 1, ldx
!         print frmt, X(i,:)
!       end do
!       print *, ""

      !=================================================================
      ! Finalize PLASMA
      !=================================================================
      call plasma_finalize(info)

      !=================================================================
      ! Perform linear system A*X=B solution check
      !=================================================================

      ! Calculate infinite norms of matrices Aref and X
      Anorm = zlange('I', n, n,    Aref, lda, work)
      Xnorm = zlange('I', n, nrhs, X,    ldx, work)

      ! Calculate residual R = A*X-B, store result in B
      call zgemm('N', 'N', n, nrhs, n, zone, Aref, lda, X, ldx, &
                  zmone, B, ldb)

      ! Calculate infinite norm of resudual matrix R
      Rnorm = zlange('I', n, nrhs, B, ldb, work)

      ! Calculate relative error
      relerr = Rnorm / n / Anorm / Xnorm

      print *, "Time:            ", telapsed
      print *, "Iter. to solve:  ", iter
      print *, "Tolerance:       ", tol
      print *, "Relative error:  ", relerr

      if (relerr < tol) then
        print *, "Solution: CORRECT"
      else
        print *, "Solution: WRONG"
      end if
      write(*,'(a)') ""

      ! Deallocate matrices
      deallocate(A, Aref, X, B, work, stat=info)

      end program test_zcposv


module vector_class

  use basis_class, only : basis
  implicit none

  type :: vector

     type(basis) :: B ! rectangular, spherical, cylindrical
     real(8)  :: coordinates(3)

   contains

     procedure :: decompose

  end type vector

  ! Constructor
  interface vector
     module procedure create_vector
  end interface vector

contains

  function decompose(this, B) result(q)

    class(vector), intent(in) :: this
    type(basis), intent(in) :: B
    real(8) :: q(3)
    real(8) :: qtmp(3)

    call this % B % basis_vector_product(this % coordinates, qtmp)
    call B % transposed_basis_vector_product(qtmp, q)

  end function decompose

  type(vector) function create_vector(coordinates, base) result (this)

    real(8), intent(in) :: coordinates(3)
    type(basis), intent(in) :: base

    this % coordinates = coordinates
    this % B = base

  end function create_vector

end module vector_class

!=====================================================================!
!
!=====================================================================!

program test_vector

  use vector_class, only : vector
  use basis_class, only : basis

  type(basis) :: rect_basis
  type(basis) :: spherical
  type(basis) :: cylindrical
  type(vector) :: v

  cylindrical = basis()
  v = vector([1.0d0, 2.0d0, 3.0d0], cylindrical)
  print *, v % decompose(cylindrical)

end program test_vector


c=======================================================================
c
c     subroutine initfeas
c
c     test QP problem feasibility
c
c-----------------------------------------------------------------------
      SUBROUTINE initfeas(n, cinf, csup, neq, nin, ccst, bcst,
     &                    iwork, dwork, wopt, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : problem size                                    integer
c       cinf   : lower bounds (n)                                 double
c       csup   : upper bounds (n)                                 double
c       neq    : number of equality constraints                  integer
c       nin    : number of inequality constraints                integer
c       ccst   : constraints matrix (n*(neq + nin + 1))           double
c       bcst   : constraints vector (neq + nin + 1)               double
c
c     WORKSPACE
c       iwork  : 3*n + 2*nin + neq + 1                           integer
c       dwork  : n*(neq+nin+2*n+15)+2*neq+4*nin+13                double
c
c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       info   : diagnostic argument                             integer
c
c     CALL
c       buildfeas, qp, YV
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, info
      DOUBLE PRECISION cinf(*), csup(*), ccst(*), bcst(*), wopt(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
      INTEGER iwork(*)
c
c     local variables
      INTEGER i, n1, infot, piw, pdwopt, pdcov, pdlin, pdccst,
     &        pdcinf, pdcsup, pdlagr, pdw
      DOUBLE PRECISION dmax, temp, EPS, DZERO
      PARAMETER (EPS=1.E-8, DZERO=0.0)
c
c-----------------------------------------------------------------------
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piw  = 1
c     piw  : pointer for QP (3*n + neq + 2*nin + 1)
c
c     Total so size of iwork array = 3*n + neq + 2*nin + 1
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      n1 = n + 1
      pdwopt = 1
c     needs n1
c        so n1
      pdcov = pdwopt + n1
c     needs n1*n1
c       so n1*n1+n1
      pdlin = pdcov + n1*n1
c     needs n1
c       so n1*n1+2*n1
      pdccst = pdlin + n1
c     needs n1*(neq+nin)
c       so n1*(neq+nin+n1+2)
      pdcinf = pdccst + n1*(neq+nin)
c     needs n1
c      so n1*(neq+nin+n1+3)
      pdcsup = pdcinf + n1
c     needs n1
c      so n1*(neq+nin+n1+4)
      pdlagr = pdcsup + n1
c     needs n1+neq+nin
c       so n1*(neq+nin+n1+5)+neq+nin
      pdw = pdlagr + n1+neq+nin
c     needs n1*(n1 + 6) + 2*nin
c       so n1*(neq+nin+2*n1+11)+neq+3*nin  = n*(neq+nin+2*(n+1)+11)+neq+3*nin+neq+nin+2*(n+1)+11
c           = n*(neq+nin+2*n+15)+2*neq+4*nin+13
c
c------------------------------------------------------------------------
c
      CALL buildfeas (n, cinf, csup, neq, nin, ccst, n1, dwork(pdcinf),
     &                dwork(pdcsup), dwork(pdccst), dwork(pdcov),
     &                dwork(pdlin), info)
      IF (info .LT. 0) THEN
        info = -8888
        RETURN
      ENDIF
c
c     quadratic solver
      CALL qp(n1, dwork(pdcov), dwork(pdlin), neq, nin,
     &        dwork(pdccst), bcst, dwork(pdcinf), dwork(pdcsup),
     &        iwork(piw), dwork(pdw), dwork(pdlagr),
     &        dwork(pdwopt), info)
      CALL YV(n, dwork(pdwopt), wopt)
      IF (info .NE. 0) RETURN
      CALL PMTV(n, (neq+nin), ccst, wopt, dwork(pdw))
      dmax = 0.0
      DO i = 1,(neq+nin)
        temp = dwork(pdw+i-1)-bcst(i)
        IF (temp .GT. dmax) dmax = temp
      ENDDO
      IF (dmax .GT. (DZERO+EPS)) THEN
            info = 1111
            RETURN
      ENDIF
      CALL checklinbox (n, wopt,
     &                  neq, nin, ccst, bcst, cinf, csup,
     &                  dwork(pdw), infot)
      IF (infot .LT. 0) THEN
        info = infot
        RETURN
      ENDIF
      RETURN
      END


      PROGRAM FTEX04D
C
C  Example of KURV1DP, KURV2DP, KURVDDP.
C
      PARAMETER (IDIM=11,IOUT=201,IDTEMP=9*IDIM)
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION U
      DOUBLE PRECISION XO
      DOUBLE PRECISION YO
      DOUBLE PRECISION XS
      DOUBLE PRECISION YS
      DOUBLE PRECISION XD
      DOUBLE PRECISION YD
      DOUBLE PRECISION XDD
      DOUBLE PRECISION YDD
      DOUBLE PRECISION XP
      DOUBLE PRECISION YP
      DOUBLE PRECISION S
      DOUBLE PRECISION SIGMA
      DOUBLE PRECISION SLOP1
      DOUBLE PRECISION SLOP2
      DOUBLE PRECISION TINC
      DIMENSION X(IDIM),Y(IDIM),TEMP(IDTEMP),U(IOUT),XO(IOUT),YO(IOUT),
     +          XS(IOUT),YS(IOUT),XD(IOUT),YD(IOUT),XDD(IOUT),YDD(IOUT)
      DIMENSION XP(IDIM),YP(IDIM),S(IDIM)
C
      DATA X/3.D0,4.D0,9.D0,16.D0,21.D0,27.D0,34.D0,36.D0,34.D0,26.D0,
     +     18.D0/
      DATA Y/2.4D0,9.6D0,14.4D0,12.0D0,9.6D0,8.4D0,13.2D0,21.6D0,30.0D0,
     +     37.2D0,38.4D0/
C
C  Do KURV1DP set up.
C
      SIGMA = 1.D0
      ISF = 3
      CALL KURV1DP(IDIM,X,Y,SLOP1,SLOP2,ISF,XP,YP,TEMP,S,SIGMA,IERR)
      IF (IERR.NE.0) THEN
          PRINT *,'Error return from KURV1DP =',IERR
          STOP
      END IF
C
C  Get interpolated points using KURV2DP.
C
      TINC = 1.0D0/ (IOUT-1)
      DO 10 I = 1,IOUT
          U(I) = (I-1)*TINC
          CALL KURV2DP(U(I),XO(I),YO(I),IDIM,X,Y,XP,YP,S,SIGMA)
   10 CONTINUE
C
C  Get the derivatives.
C
      DO 20 I = 1,IOUT
          CALL KURVDDP(U(I),XS(I),YS(I),XD(I),YD(I),XDD(I),YDD(I),IDIM,
     +        X,Y,XP,YP,S,SIGMA)
   20 CONTINUE
C
C This next section plots the data. You must have a double precision
C version of NCAR Graphics in order for this section to compile and
C run correctly.  For now, it is commented out.
C
C  Draw plot.
C
C      CALL DRWFT4(IDIM,X,Y,IOUT,XO,YO,U,XD,YD)
C
      STOP
      END
C      SUBROUTINE DRWFT4(II,X,Y,IOUT,XO,YO,U,XD,YD)
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
C      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C      DOUBLE PRECISION X
C      DOUBLE PRECISION Y
C      DOUBLE PRECISION XO
C      DOUBLE PRECISION YO
C      DOUBLE PRECISION U
C      DOUBLE PRECISION XD
C      DOUBLE PRECISION YD
C
C  Open GKS, open and activate a workstation.
C
C      CALL GOPKS(IERRF,ISZDM)
C      CALL GOPWK(IWKID,LUNIT,IWTYPE)
C      CALL GACWK(IWKID)
C
C  Define a color table.
C
C      CALL GSCR(IWKID,0,1.0D0,1.0D0,1.0D0)
C      CALL GSCR(IWKID,1,0.0D0,0.0D0,0.0D0)
C      CALL GSCR(IWKID,2,1.0D0,0.0D0,0.0D0)
C      CALL GSCR(IWKID,3,0.0D0,1.0D0,0.0D0)
C      CALL GSCR(IWKID,4,0.0D0,0.0D0,1.0D0)
C
C  Draw markers at original points.
C
C      CALL BKGFT4(0.D0,40.D0,0.D0,40.D0,0.15D0,0.85D0,
C     +            'Demo for KURV1DP/KURV2DP',0.035D0,0.5D0,0.93D0,0)
C      CALL GRIDAL(4,5,4,5,1,1,10,0.D0,0.D0)
C      CALL GSMKSC(2.D0)
C      CALL GSPMCI(4)
C      CALL GPM(II,X,Y)
C
C  Draw the interpolated curve
C
C      CALL CURVE(XO,YO,IOUT)
C      CALL FRAME
C
C  Plot the first derivatives of X and Y with respect to the parametric
C  variable U.
C
C      CALL SET(0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,1)
C      CALL PCSETI('FN',21)
C      CALL PLCHHQ(0.5D0,0.95D0,'Derivatives from KURVDDP',0.035D0,0.D0,
C     +            0.D0)
C      CALL BKGFT4(0.D0,1.D0,-80.D0,80.D0,0.55D0,0.87D0,'dx/du',0.030D0,
C     +            0.65D0,0.82D0,1)
C      CALL GRIDAL(5,5,4,5,1,1,10,0.D0,-80.D0)
C      CALL CURVE(U,XD,IOUT)
C      CALL BKGFT4(0.D0,1.D0,-40.D0,80.D0,0.10D0,0.42D0,'dy/du',0.030D0,
C     +            0.39D0,0.37D0,1)
C      CALL GRIDAL(5,5,3,5,1,1,10,0.D0,-40.D0)
C      CALL CURVE(U,YD,IOUT)
C      CALL FRAME
C
C      CALL GDAWK(IWKID)
C      CALL GCLWK(IWKID)
C      CALL GCLKS
C
C      RETURN
C      END
C      SUBROUTINE BKGFT4(XL,XR,YB,YT,YPB,YPT,LABEL,SIZL,POSXL,POSYL,IZL)
C      DOUBLE PRECISION XL
C      DOUBLE PRECISION XR
C      DOUBLE PRECISION YB
C      DOUBLE PRECISION YT
C      DOUBLE PRECISION YPB
C      DOUBLE PRECISION YPT
C      DOUBLE PRECISION SIZL
C      DOUBLE PRECISION POSXL
C      DOUBLE PRECISION POSYL
C      DOUBLE PRECISION XX
C      DOUBLE PRECISION YY
C      DIMENSION XX(2),YY(2)
C      CHARACTER*(*) LABEL
C
C      CALL SET(0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,1)
C      CALL PCSETI('FN',21)
C      CALL PLCHHQ(POSXL,POSYL,LABEL,SIZL,0.D0,0.D0)
C      CALL SET(0.17D0,0.87D0,YPB,YPT,XL,XR,YB,YT,1)
C      IF (IZL.NE.0) THEN
C          XX(1) = XL
C          XX(2) = XR
C          YY(1) = 0.D0
C          YY(2) = 0.D0
C          CALL GSPLCI(2)
C          CALL GPL(2,XX,YY)
C          CALL GSPLCI(1)
C      END IF
C
C      CALL GASETI('LTY',1)
C      CALL PCSETI('FN',21)
C      CALL GASETR('XLS',0.02D0)
C      CALL GASETC('XLF','(F4.1)')
C      CALL GASETR('YLS',0.02D0)
C      CALL GASETC('YLF','(F5.1)')
C      CALL GASETR('XMJ',0.02D0)
C      CALL GASETR('YMJ',0.02D0)
C
C      RETURN
C      END