C NCLFORTSTART
      SUBROUTINE DDTRNDX(X,NPTS,IOPT,XMEAN,XVARI,XVARO,C,IER)
      IMPLICIT NONE
      INTEGER NPTS, IOPT, IER
      DOUBLE PRECISION X(NPTS),C(3)
      DOUBLE PRECISION XMEAN
      DOUBLE PRECISION XVARI
      DOUBLE PRECISION XVARO
C NCLEND

      INTEGER I, N
      DOUBLE PRECISION XCNTR
      DOUBLE PRECISION FN
      DOUBLE PRECISION SUMX
      DOUBLE PRECISION SUMY
      DOUBLE PRECISION SUMX2
      DOUBLE PRECISION SUMX3
      DOUBLE PRECISION SUMX4
      DOUBLE PRECISION SUMXY
      DOUBLE PRECISION SUMX2Y
      DOUBLE PRECISION XS
      DOUBLE PRECISION D
      DOUBLE PRECISION XBAR

C DETREND THE SERIES X

C NOMENCLATURE :

C .   INPUT

C .   X         - SERIES TO BE DETRENDED
C .   NPTS      - LENGTH OF X
C .   IOPT      - DETRENDING OPTION
C .               IOPT < 0 : CALCULATE THE MEAN AND VARIANCE OF X THEN
C .                          RETURN
C .               IOPT = 0 : REMOVE THE MEAN ONLY
C .               IOPT = 1 : REMOVE THE MEAN AND USE LINEAR LST SQRS TO
C .                          DETREND
C .               IOPT = 2 : REMOVE THE MEAN AND USE QUADRATIC
C .                          LST SQRS TO DETRD
C .
C .   OUTPUT
C .
C .   XMEAN     - MEAN OF THE ORIGINAL INPUT  SERIES (OUTPUT)
C .   XVARI     - VARIANCE OF THE ORIGINAL INPUT SERIES (OUTPUT)
C .   XVARO     - VARIANCE OF THE DETRENDED SERIES (OUTPUT)
C .               NOTE : XVARI = XVARO WHEN IOPT @ 0
C .   C         - COEFFICIENTS OF THE LEAST SQUARES POLYNOMIAL (OUTPUT)
C .               MUST BE DIMENSIONED (3) IN THE CALLING PROGRAM
C .               C(1)  CONSTANT
C .               C(2)  COEF OF FIRST POWER [SLOPE IF IOPT=1]
C .               C(3)  COEF OF SECOND POWER
C .   IER       - ERROR CODE

      C(1) = 0.D0
      C(2) = 0.D0
      C(3) = 0.D0

      IER = 0
      IF (NPTS.LT.2) IER = -21
      IF (IER.NE.0) RETURN

      N  = NPTS
      FN = DBLE(N)

C CALCULATE THE MEAN AND VARIANCE OF THE INPUT SERIES

      XMEAN = 0.0D0
      XVARI = 0.0D0
      DO I = 1,N
         XMEAN = XMEAN + X(I)
         XVARI = XVARI + X(I)*X(I)
      END DO
      XVARI = (XVARI-XMEAN*XMEAN/FN)/FN
      XMEAN = XMEAN/FN
      XVARO = XVARI

      IF (IOPT.LT.0) RETURN

C MUST AT LEAST WANT THE SERIES MEAN REMOVED (IOPT=0)

      DO I = 1,N
          X(I) = X(I) - XMEAN
      END DO

      IF (IOPT.EQ.1) THEN

C MUST ALSO WANT LEAST SQUARES TREND LINE REMOVED

          C(2) = 0.D0
          XCNTR = DBLE(N+1)*0.5D0
          DO I = 1,N
             C(2) = C(2) + X(I)* (DBLE(I)-XCNTR)
          END DO

C orig    C(2) = C(2)*12.D0/DBLE(N* (N*N-1))
          C(2) = (C(2)/FN)*(12.D0/(FN*FN-1.D0))

C Y-INTERCEPT
          C(1) = XMEAN - C(2)*XCNTR

          DO I = 1,N
             X(I) = X(I) - C(2)* (DBLE(I)-XCNTR)
          END DO

      ELSE IF (IOPT.EQ.2) THEN

C MUST WANT QUADRATIC DETRENDING

          SUMX = 0.D0
          SUMY = 0.D0
          SUMX2 = 0.D0
          SUMX3 = 0.D0
          SUMX4 = 0.D0
          SUMXY = 0.D0
          SUMX2Y = 0.D0
          DO 50 I = 1,N
              XS = DBLE(I)
              SUMX = SUMX + XS
              SUMY = SUMY + X(I)
              SUMX2 = SUMX2 + XS**2
              SUMX3 = SUMX3 + XS**3
              SUMX4 = SUMX4 + XS**4
              SUMXY = SUMXY + XS*X(I)
              SUMX2Y = SUMX2Y + XS**2*X(I)
   50     CONTINUE
          D = FN* (SUMX2*SUMX4-SUMX3**2) +
     +        SUMX* (SUMX3*SUMX2-SUMX*SUMX4) +
     +        SUMX2* (SUMX*SUMX3-SUMX2**2)
          C(1) = (SUMX2*SUMX4-SUMX3**2)*SUMY +
     +           (SUMX3*SUMX2-SUMX*SUMX4)*SUMXY +
     +           (SUMX*SUMX3-SUMX2**2)*SUMX2Y
          C(2) = (SUMX3*SUMX2-SUMX*SUMX4)*SUMY +
     +           (FN*SUMX4-SUMX2**2)*SUMXY +
     +           (SUMX*SUMX2-FN*SUMX3)*SUMX2Y
          C(3) = (SUMX*SUMX3-SUMX2**2)*SUMY +
     +           (SUMX*SUMX2-FN*SUMX3)*SUMXY + (FN*SUMX2-SUMX**2)*SUMX2Y
          C(1) = C(1)/D
          C(2) = C(2)/D
          C(3) = C(3)/D
          DO 60 I = 1,N
   60     X(I) = X(I) - (C(1)+C(2)*DBLE(I)+C(3)*DBLE(I)**2)

      END IF

C CALCULATE THE VARIANCE OF THE DETRENDED SERIES
C .   XBAR SHOULD BE ZERO TO MACHINE ACCURACY SUBTRACT IT OUT ANYWAY

      XBAR  = 0.0D0
      XVARO = 0.0D0
      DO I = 1,N
         XBAR = XBAR + X(I)
         XVARO = XVARO + X(I)*X(I)
      END DO
      XVARO = (XVARO-XBAR*XBAR/FN)/FN

      XBAR = XBAR/FN
      DO I = 1,N
         X(I) = X(I) - XBAR
      END DO

      RETURN
      END
c -------------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE DDTRNDMSG(X,Y,NPTS,XMSG,YMSG,IOPT
     *                    ,YDT,SLOPE,YINT,IER)
      IMPLICIT NONE
      INTEGER NPTS,IOPT,IER
      DOUBLE PRECISION X(NPTS),Y(NPTS),SLOPE,YINT,YDT(NPTS)
      DOUBLE PRECISION XMSG,YMSG
C NCLEND

c NCL:   yNew = dtrend_msg (x[*]:numeric, y:numeric
c                          ,remove_mean:logical, return_info:logical)

c this routine will calculate the least squares "slope" and y-intercept
c .   remove the trend.
c .   (a) missing data are allowed.
c .   (b) data need not be equally spaced in "x"

c .   yLine = slope*y + yint
c .   ydt   = y - yLine

c arguments :
c .   x,y      - input vectors
c .   npts     - length of vectors x and y
c .   x/ymsg   - missing code: if no msg values set to some number
c .                            which will not be encountered.
c .              ymsg will be used to fill missing values
c .   iopt     - =1: (True)  Return YDT with the mean removed
c .              =0: (Flase) do not remove the mean
c .   ydt      - detrended series
c .              this could be "y" if original series not needed
c .   slope    - slope (trend ... regression coef)
c .   yint     - y-intercept of the INPUT series
c .   ier      - if (ier.ne.0) an error has occurred

c                                      local
      INTEGER N
      DOUBLE PRECISION XDT(1:NPTS)
      DOUBLE PRECISION XYN,XSUM,YSUM,X2SUM,Y2SUM,XYSUM
      DOUBLE PRECISION XBAR,YBAR,XVAR,YVAR,XYVAR
      DOUBLE PRECISION XAVE,YAVE,XTOT,YTOT,YDTINT

      IER = 0
      SLOPE = YMSG
      YINT = YMSG

      IF (NPTS.LT.2) IER = 1
      IF (IER.NE.0) RETURN
c                               copy original series
      DO N = 1,NPTS
         XDT(N) = X(N)
         YDT(N) = Y(N)
      END DO
c                               loop to calculate sums
      XYN  = 0.0D0
      XSUM = 0.0D0
      YSUM = 0.0D0
      DO N = 1,NPTS
         IF (XDT(N).NE.XMSG .AND. YDT(N).NE.YMSG) THEN
             YSUM = YSUM + YDT(N)
             XSUM = XSUM + XDT(N)
             XYN  = XYN  + 1.D0
         END IF
      END DO
c                               all msg values or only one good point
c                                                    (not enough data)
      IF (XYN.LT.2.D0) THEN
          IER = 5
          RETURN
      END IF
c                               calculate mean of X and Y
      XBAR = XSUM/XYN
      YBAR = YSUM/XYN
C      print *,"                            "
C      print *," -------------------------- "
C      print *,"XBAR=",XBAR,"  YBAR=",YBAR
c                               remove the X and Y means
c                               This shifts the data: minimize
c                               roundoff for big X and/or Y numbers
      DO N = 1,NPTS
         IF (X(N).NE.XMSG .AND. Y(N).NE.YMSG) THEN
             XDT(N) = X(N) - XBAR
             YDT(N) = Y(N) - YBAR
C             print *,"N=",N,"  XDT(N)="+XDT(N),"  YDT(N)="+YDT(N)
C     *                     ,"  Y(N)="+Y(N)
         END IF
      END DO
c                               stats for shifted series
      XTOT  = 0.0D0
      YTOT  = 0.0D0
      X2SUM = 0.0D0
      Y2SUM = 0.0D0
      XYSUM = 0.0D0
      DO N=1,NPTS
         IF (X(N).NE.XMSG .AND. Y(N).NE.YMSG) THEN
             XTOT  = XTOT  + XDT(N)
             YTOT  = YTOT  + YDT(N)
             X2SUM = X2SUM + XDT(N)*XDT(N)
             Y2SUM = Y2SUM + YDT(N)*YDT(N)
             XYSUM = XYSUM + XDT(N)*YDT(N)
         END IF
      END DO
c                               XAVE/YAVE should be 0.0
      XAVE  = XTOT/XYN
      YAVE  = YTOT/XYN
      XVAR  = X2SUM - XTOT*XTOT/XYN
      YVAR  = Y2SUM - YTOT*YTOT/XYN
      XYVAR = XYSUM - XTOT*YTOT/XYN

c                               slope and y-intercept: shifted series
      SLOPE = XYVAR/XVAR
      YDTINT= YAVE - SLOPE*XAVE
C      print *,"SLOPE=",SLOPE,"  YDTINT=",YDTINT, "  XAVE=",XAVE
C     *                      ,"  YAVE=",YAVE

c                               detrend the (mean removed) series
      DO N = 1,NPTS
          IF (X(N).NE.XMSG .AND. Y(N).NE.YMSG) THEN
              YDT(N) = YDT(N) - (SLOPE*XDT(N)+YDTINT)
          ELSE
              YDT(N) = YMSG
          END IF
      END DO

c                               return mean ?
      YINT = YBAR - SLOPE*XBAR
      IF (IOPT.EQ.0) THEN
          DO N = 1,NPTS
             IF (YDT(N).NE.YMSG) THEN
                 YDT(N) = YDT(N) + YBAR
             END IF
          END DO
      END IF

      RETURN
      END


C
C********************** MAP PROJECTION ROUTINES ****************************
C
C
C
        SUBROUTINE XYTOPS(X,Y,PLA,PLO,ERAD)
C
C     This convert x,y-polar stereographic coordinates to
C     lat/lon values.
C     longitude:   0 - 180  ; Greenwich and east, 0 - -180 Greenwich and west
C     latitude : -90 -  90  ; positive for northern hemisphere
C     It is assumed that the x-axis point towards the east why the
C     longitude is rotated relative to the 'standard pol.ste.' location
C
      PI180=3.14159265/180.
      VDIST = ERAD*2.0
C
C     calculate distance from (0,0) and define (0,0) as 90,0 (90,-90 in
C     the rotated system)
C
      DIST=SQRT(X**2+Y**2)
      IF(DIST.EQ.0) THEN
         PLA= 90.0
         PLO=-90.0
      ELSE
C
C     calculate the latitude by means of atan
C
         PLA=ATAN(DIST/VDIST)/PI180
         PLA=90.0-2.0*PLA
C
C     calculate the longitude taking the directions into account
C
         IF(X.EQ.0.0) THEN
            IF(Y.GT.0.0) THEN
               PLO= 90.0
            ELSE
               PLO=-90.0
            END IF
         ELSE
            IF(X.GT.0.0) THEN
               PLO=ATAN(Y/X)/PI180
            ELSE
               PLO=ATAN(Y/X)/PI180+180.0
            END IF
         END IF
      END IF
C
C     rotate the longitude
C
      PLO=AMOD(PLO+450.0,360.0)
      RETURN
      END
C
C     *******************************************************************
C
      SUBROUTINE PSTOGE(PLA,PLO,GLAT,GLON,RLAT,WLON1)
C
C     Convert polar stereographic coordinates to geographical lat/lon
C     ditto with the pol.ste. pole at rlat,wlon1
C
C     longitude:   0 ; 360 positive east (on input)
C               -180 ; 180 positive east (on output)
C     latitude : -90 ;  90 posive on northern hemisphere
C     It is assumed that the polar stereographic coordinates have been
C     rotated to the standard format with 0 degrees longitude along wlon1
C
C     TSP 21 JUNE 89
C
C     set flag for n/s hemisphere
C
      PI180=3.14159265/180.
C
      IF(RLAT.GE.0.0) THEN
         HSIGN= 1.0
      ELSE
         HSIGN=-1.0
      END IF
C
C     test for a n/s pole case
C
      IF(RLAT.EQ.90.0) THEN
	 GLAT=PLA
         GLON=MOD(PLO+WLON1,360.0)
         GO TO 2000
      END IF
      IF(RLAT.EQ.-90.0) THEN
         GLAT=-PLA
         GLON=MOD(PLO+WLON1,360.0)
         GO TO 2000
      END IF
C
C     test for longitude on 'greenwich or date line'
C
      IF(PLO.EQ.0) THEN
         GLAT=RLAT-90.0+PLA
         IF(GLAT.LT.-90.0) THEN
            GLAT=-180.0-GLAT
            GLON=MOD(WLON1+180.0,360.0)
         ELSE
            GLON=WLON1
         END IF
         GO TO 2000
      END IF
      IF(PLO.EQ.180.0) THEN
         GLAT=RLAT+90.0-PLA
         IF(GLAT.GT.90.0) THEN
            GLAT=180.0-GLAT
            GLON=MOD(WLON1+180.0,360.0)
         ELSE
            GLON=WLON1
         END IF
         GO TO 2000
      END IF
C
C     Determine longitude distance relative to wlon1 so it belongs to
C     the absolute interval 0 - 180
C
      ARGU1=PLO
      IF(PLO.GT.180.0) ARGU1 = PLO-360.0
C
C     Get the latitude, the help circle BB and the longitude by first
C     calculating the argument and legalize it - then take the inverse fct.
C
      IF(HSIGN.GT.0.0) THEN
         ARG2A = SIN(PLA*PI180)*SIN(HSIGN*RLAT*PI180)+
     +        COS(PLA*PI180)*COS(RLAT*PI180)*COS((180.0-ARGU1)*PI180)
      ELSE
         ARG2A = SIN(PLA*PI180)*SIN(HSIGN*RLAT*PI180)+
     +        COS(PLA*PI180)*COS(RLAT*PI180)*COS(ARGU1*PI180)
      END IF
      ARG2A = MIN(ARG2A, 1.0)
      ARG2A = MAX(ARG2A,-1.0)
      GLAT  = HSIGN*ASIN(ARG2A)
C
      IF(HSIGN.GT.0.0) THEN
         ARG2A = COS(RLAT*PI180)*SIN(PLA*PI180)+
     +        SIN(RLAT*PI180)*COS(PLA*PI180)*COS(ARGU1*PI180)
      ELSE
         ARG2A = COS(RLAT*PI180)*SIN(PLA*PI180)+
     +       SIN(-RLAT*PI180)*COS(PLA*PI180)*COS((180.0-ARGU1)*PI180)
      END IF
      ARG2A = MIN(ARG2A, 1.0)
      ARG2A = MAX(ARG2A,-1.0)
      BB    = ACOS(ARG2A)
C
!     ARG2A = COS(GLAT)*COS(BB)/(1.0-SIN(GLAT)**2)
      ARG2A = COS(BB)/COS(GLAT)              ! 1997 Steve Albers
      ARG2A = MIN(ARG2A, 1.0)
      ARG2A = MAX(ARG2A,-1.0)
      GLON  = ACOS(ARG2A)
C
C     convert the radians to degrees
C
        GLAT = GLAT/PI180
        GLON = GLON/PI180
C
C       the solution is symmetric so the direction must be if'ed
C
        IF(ARGU1.LT.0.0) THEN
           GLON = 360.0-GLON
        END IF
        GLON=AMOD(GLON+WLON1,360.0)
C
 2000 CONTINUE
C
C     the resultant longitude must be in the interval from -180, 180
C
      IF(GLON.GT.180.0) GLON=GLON-360.0
      RETURN
      END

C     ****************************************************************
C
      SUBROUTINE GETOPS(PLA_r4,PLO_r4,GLAT_r4,GLON_r4,RLAT_r4,WLON1_r4)
C                        Out     Out    In      In      In       In
C
C     Convert geographical lat/lon coordinates to polar stereographic
C     ditto with the pol.ste. pole at RLAT,WLON1
C
C     longitude:-180 ; 180 positive east (on input)
C              :   0 ; 360 positive east (on output)
C     latitude : -90 ;  90 posive on northern hemisphere
C     The result is rotated 270 degrees relative to 'standard pol.ste.'
C     WLON1 is defined in the same way as the input
C     approach so as to get the x-axis to point towards the east, and the
C     y-axis towards the north along 0 degrees (at NP south along 180)
C
C     TSP 20/06-89
C
C     constants
C
      implicit real*8 (a-h,o-z)

      real pla_r4,plo_r4,glat_r4,glon_r4,rlat_r4,wlon1_r4

      PLA = pla_r4
      PLO = plo_r4
      GLAT = glat_r4
      GLON = glon_r4
      RLAT = rlat_r4
      WLON1 = wlon1_r4

      PI180 = 3.1415926535897932/180.0
C
C     Set flag for N/S hemisphere and convert longitude to <0 ; 360> interval
C
      IF(RLAT.GE.0.0) THEN
         HSIGN= 1.0
      ELSE
         HSIGN=-1.0
      END IF
      GLOR=GLON
      IF(GLOR.LT.0.0) GLOR=360.0+GLOR
      RWLON1=WLON1
      IF(RWLON1.LT.0.0) RWLON1=360.0+WLON1
C
C     Test for a N/S pole case
C
      IF(RLAT.EQ.90.0) THEN
         PLA=GLAT
         PLO=DMOD(GLOR+270.0D0,360.0D0)
         GO TO 2000
      END IF
      IF(RLAT.EQ.-90.0) THEN
         PLA=-GLAT
         PLO=DMOD(GLOR+270.0D0,360.0D0)
         GO TO 2000
      END IF
C
C     Test for GE coordinates at PS pole (Steve Albers - 1998)
C
      if(GLAT .eq. RLAT .and. GLON .eq. WLON1)then
         PLA = 90.0
         PLO = 0.
         GOTO2000
      endif
C
C     Test for longitude on 'Greenwich or date line'
C
      IF(GLOR.EQ.RWLON1) THEN
         IF(GLAT.GT.RLAT) THEN
            PLA=90.0-GLAT+RLAT
            PLO=90.0
         ELSE
            PLA=90.0-RLAT+GLAT
            PLO=270.0
         END IF
         GO TO 2000
      END IF
      IF(DMOD(GLOR+180.0D0,360.0D0).EQ.RWLON1) THEN
         PLA=RLAT-90.0+GLAT
         IF(PLA.LT.-90.0) THEN
            PLA=-180.0-PLA
            PLO=270.0
         ELSE
            PLO= 90.0
         END IF
         GO TO 2000
      END IF
C
C     Determine longitude distance relative to RWLON1 so it belongs to
C     the absolute interval 0 - 180
C
      ARGU1 = GLOR-RWLON1
      IF(ARGU1.GT. 180.0) ARGU1 = ARGU1-360.0
      IF(ARGU1.LT.-180.0) ARGU1 = ARGU1+360.0
C
C     1. Get the help circle BB and angle ALPHA (legalize arguments)
C
      ARG2A = COS(GLAT*PI180)*COS(ARGU1*PI180)
      ARG2A = MAX(ARG2A,-1.0D0)
      ARG2A = MIN(ARG2A, 1.0D0)
      BB    = ACOS(ARG2A)
C
      ARG2A = SIN(HSIGN*GLAT*PI180)/SIN(BB)
      ARG2A = MAX(ARG2A,-1.0D0)
      ARG2A = MIN(ARG2A, 1.0D0)
      ALPHA = ASIN(ARG2A)
C
C     2. Get PLA and PLO (still legalizing arguments)
C
      ARG2A = COS(RLAT*PI180)*COS(BB)+
     +        SIN(HSIGN*RLAT*PI180)*SIN(HSIGN*GLAT*PI180)
      ARG2A = MAX(ARG2A,-1.0D0)
      ARG2A = MIN(ARG2A, 1.0D0)
      PLA   = ASIN(ARG2A)
C
      ARG2A = SIN(BB)*COS(ALPHA)/COS(PLA)
      ARG2A = MAX(ARG2A,-1.0D0)
      ARG2A = MIN(ARG2A, 1.0D0)
      PLO   = ASIN(ARG2A)
C
C    Test for passage of the 90 degree longitude (duallity in PLO)
C         Get PLA for which PLO=90 when GLAT is the latitude
C
      ARG2A = SIN(HSIGN*GLAT*PI180)/SIN(HSIGN*RLAT*PI180)
      ARG2A = MAX(ARG2A,-1.0D0)
      ARG2A = MIN(ARG2A, 1.0D0)
      PLA90 = ASIN(ARG2A)
C
C         Get help arc BB and angle ALPHA
C
      ARG2A = COS(RLAT*PI180)*SIN(PLA90)
      ARG2A = MAX(ARG2A,-1.0D0)
      ARG2A = MIN(ARG2A, 1.0D0)
      BB    = ACOS(ARG2A)

      ARG2A = SIN(HSIGN*GLAT*PI180)/SIN(BB)
      ARG2A = MAX(ARG2A,-1.0D0)
      ARG2A = MIN(ARG2A, 1.0D0)
      ALPHA = ASIN(ARG2A)
C
C         Get GLOLIM - it is nesc. to test for the existence of solution
C
      ARGU2  = COS(GLAT*PI180)*COS(BB)/
     +            (1.-SIN(HSIGN*GLAT*PI180)*SIN(BB)*SIN(ALPHA))
      IF(ABS(ARGU2).GT.1.0) THEN
      GLOLIM = 999.0
      ELSE
        GLOLIM = ACOS(ARGU2)/PI180
      END IF
C
C     Modify (if nesc.) the PLO solution
C
      IF((ABS(ARGU1).GT.GLOLIM.AND.GLAT.LE.RLAT).OR.
     +   GLAT.GT.RLAT) THEN
            PLO = PI180*180.0 - PLO
      END IF
C
C     The solution is symmetric so the direction must be if'ed
C
      IF(ARGU1.LT.0.0) THEN
         PLO = -PLO
      END IF
C
C     Convert the radians to degrees
C
      PLA = PLA/PI180
      PLO = PLO/PI180
C
C     To obtain a rotated value (ie so x-axis in pol.ste. points east)
C     add 270 to longitude
C
      PLO=DMOD(PLO+270.0D0,360.0D0)
C
 2000 CONTINUE

      pla_r4 = PLA
      plo_r4 = PLO
!     glat_r4 = GLAT
!     glon_r4 = GLON
      rlat_r4 = RLAT
      wlon1_r4 = WLON1

      RETURN
      END
C
C     ******************************************************************
C
      SUBROUTINE PSTOXY(X,Y,PLA,PLO,ERAD)
C
C     This program convert polar stereographic coordinates to x,y ditto
C     longitude:   0 - 360  ; positive to the east
C     latitude : -90 -  90  ; positive for northern hemisphere
C     it is assumed that the x-axis point towards the east and
C     corresponds to longitude = 0
C
C     TSP 20/06-89
C
C     constants and functions
C
      FAC(PLA) = ERAD*2.0/(1.0+SIN(PLA*PI180))*COS(PLA*PI180)
      XC(PLA,PLO) = FAC(PLA)*COS(PLO*PI180)
      YC(PLA,PLO) = FAC(PLA)*SIN(PLO*PI180)
      PI180=3.14159265/180.0
C
C     Calculate the coordinates
C
      X = XC(PLA,PLO)
      Y = YC(PLA,PLO)
C
      RETURN
      END

      subroutine latlon_to_xy_old(glat,glon,rlat,wlon1,erad,x,y)

!     combines getops + pstoxy

!                  o   o   i    i    i     i
      call GETOPS(PLA,PLO,GLAT,GLON,RLAT,WLON1)

      plo = plo - wlon1

!                 o o  i   i    i
      call PSTOXY(X,Y,PLA,PLO,ERAD)

      return
      end

      subroutine latlon_to_xy(glat,glon,erad,x,y)

!     combines getops + pstoxy

      call latlon_to_uv(glat,glon,u,v,istatus)

      call uv_to_xy(u,v,erad,x,y)

      return
      end

      subroutine xy_to_latlon_old(x,y,erad,rlat,wlon1,glat,glon)

!     combines xytops + pstoge

!                 i i  o   o    i
      call XYTOPS(X,Y,PLA,PLO,ERAD)

!                  i   i    o    o    i    i
      call PSTOGE(PLA,PLO,GLAT,GLON,RLAT,WLON1)

      return
      end

      subroutine xy_to_latlon(x,y,erad,glat,glon)

!     combines xytops + pstoge

      call xy_to_uv(x,y,erad,u,v)

      call uv_to_latlon(u,v,glat,glon,istatus)

      return
      end

      subroutine xy_to_uv(x,y,erad,u,v)

      use mem_namelist, ONLY: c6_maproj,slat1=>standard_latitude
     1                                 ,slat2=>standard_latitude2
     1                                 ,grid_spacing_m

      include 'trigd.inc'

      real n

      if(c6_maproj .eq. 'plrstr')then     ! Haltiner & Williams 1-21
          call get_ps_parms(slat1,slat2,grid_spacing_m,phi0
     1                                 ,grid_spacing_proj_m)
          factor = 1. + sind(phi0)

          u = x / (factor * erad)
          v = y / (factor * erad)

      elseif(c6_maproj .eq. 'lambrt')then
          call lambert_parms(slat1,slat2,n,s,rconst)

          u = x / (erad * rconst)
          v = y / (erad * rconst)

      elseif(c6_maproj .eq. 'merctr')then ! Haltiner & Williams 1-8-2
          u = x / erad
          v = y / erad

      elseif(c6_maproj .eq. 'latlon')then
          u = x / erad
          v = y / erad

      else
          write(6,*)'xy_to_uv - Error: invalid map projection '
     1             ,c6_maproj
          stop

      endif

      return
      end

      subroutine uv_to_xy(u,v,erad,x,y)

      use mem_namelist, ONLY: c6_maproj,slat1=>standard_latitude
     1                                 ,slat2=>standard_latitude2
     1                                 ,grid_spacing_m
      include 'trigd.inc'

      real n

      if(c6_maproj .eq. 'plrstr')then     ! Haltiner & Williams 1-21
          call get_ps_parms(slat1,slat2,grid_spacing_m,phi0
     1                                 ,grid_spacing_proj_m)
          factor = 1. + sind(phi0)

          x = u * factor * erad
          y = v * factor * erad

      elseif(c6_maproj .eq. 'lambrt')then
          call lambert_parms(slat1,slat2,n,s,rconst)

          x = u * (erad * rconst)
          y = v * (erad * rconst)

      elseif(c6_maproj .eq. 'merctr')then ! Haltiner & Williams 1-8-2
          x = u * erad
          y = v * erad

      elseif(c6_maproj .eq. 'latlon')then
          x = u * erad
          y = v * erad

      else
          write(6,*)'uv_to_xy - Error: invalid map projection '
     1             ,c6_maproj
          stop

      endif

      return
      end


module co2_interpolation
implicit none

contains

    subroutine climate_interpolation(co2lev)

        double precision, intent(in):: co2lev
        include 'combine_foam.inc'
        double precision:: xi
        integer:: nclimber_minus_1

        !------------------------------------------------------------------------------!
        ! If only one CO2 level => assume constant initial CO2 for silicate weathering !
        !------------------------------------------------------------------------------!
        if (nclimber==1) then

            ! Fixed CO2 mode => keep climate at level #1
            do j0=1,ncontpxl
                j = list_cont_pixel(j0)
                Tclim(j)   = Tairclimber(j,1)
                runclim(j) = Runclimber(j,1)
            end do
            !! "Fake" climate generator:
            !!   uniform 4°C warming and 25% runoff increase per doubling of CO2
            !do j0=1,ncontpxl
            !    j = list_cont_pixel(j0)
            !    Tclim(j)   = Tairclimber(j,1) + (4./log(2.)) * log(co2lev/co2climber(1))
            !    runclim(j) = Runclimber(j,1) * (1 + (0.25/log(2.)) * log(co2lev/co2climber(1)))
            !end do

        !--------------------------------------------------------------------!
        ! Otherwise, interpolate temperature and runoff at current CO2 level !
        !--------------------------------------------------------------------!
        else

            call find_co2_interval(co2climber, co2lev, k1, k2, xi)

            ! Case "out of CO2 range"
            if (co2lev < co2climber(1) .or. co2lev > co2climber(nclimber)) then

                do j0=1,ncontpxl
                    j = list_cont_pixel(j0)
                    ! "linear" extrapolation
                    Tclim(j) = (1-xi)*Tairclimber(j,k1) + xi*Tairclimber(j,k2)
                    runclim(j) = (1-xi)*Runclimber(j,k1) + xi*Runclimber(j,k2)
                    runclim(j) = max(  0d0  ,  (1-xi)*Runclimber(j,k1) + xi*Runclimber(j,k2)  )
                    ! security to avoid negative runoff in the extrapolation
                end do

            else ! Normal case

                do j0=1,ncontpxl
                    j = list_cont_pixel(j0)
                    ! "linear" interpolation
                    Tclim(j) = (1-xi)*Tairclimber(j,k1) + xi*Tairclimber(j,k2)
                    runclim(j) = (1-xi)*Runclimber(j,k1) + xi*Runclimber(j,k2)
                end do

            endif

            ! Spatialized interpolation coefficient A(x,y) and B(x,y), logarithic interpolation
            !
            !do j0=1,ncontpxl
            !    j = list_cont_pixel(j0)
            !    Tclim(j)   = ATe(j)+BTe(j)*dlog(co2lev)
            !    runclim(j) = ARu(j)+BRu(j)*Tclim(j)
            !    if (runclim(j).lt.0) runclim(j)=0
            !end do

        end if

    end subroutine

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

    subroutine find_co2_interval(co2_axis, co2, kinf, ksup, xi)

        include 'shape.inc'
        double precision, dimension(nclimber), intent(in):: co2_axis
        double precision, intent(in)::                      co2
        integer, intent(out)::                              kinf, ksup
        double precision, intent(out)::                     xi
        integer::                                           k

        kinf = 1
        ksup = nclimber
        ! find by dichotomy:
        do while ( ksup-kinf > 1 )
            k = kinf + (ksup-kinf)/2
            if (co2 >= co2_axis(k)) then
                kinf = k
            else
                ksup = k
            end if
        end do

        ! interpolation coefficient => depends on interpolation mode (linear or logarithmic):
        xi = interp_coeff(co2, co2_axis(kinf), co2_axis(ksup))

    end subroutine

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

    function interp_coeff(x, x0, x1)

        double precision:: interp_coeff
        double precision, intent(in):: x, x0, x1
        include 'coupler.inc'

        select case (interpolation_mode)
          case ('linear')
            interp_coeff = (x - x0) / (x1 - x0)
          case ('log')
            interp_coeff = log(x/x0) / log(x1/x0)
          case default
            print *
            print *, 'ERROR in "source/coupler.inc": illegal interpolation mode "'//interpolation_mode//'"'
            print *, 'Expect "linear" or "log"'
            stop
        end select

    end function

end module


c----------------------------------------------------------------------c
c                          S P A R S K I T                             c
c----------------------------------------------------------------------c
c    MATRIX GENERATION ROUTINES  -- FINITE DIFFERENCE MATRICES         c
c----------------------------------------------------------------------c
c contents:                                                            c
c----------                                                            c
c gen57pt  : generates 5-point and 7-point matrices.                   c
c gen57bl  : generates block 5-point and 7-point matrices.             c
c                                                                      c
c supporting routines:                                                 c
c---------                                                             c
c gensten  : generate the stencil (point version)                      c
c bsten    : generate the stencil (block version)                      c
c fdaddbc  : finite difference add boundary conditions                 c
c fdreduce : reduce the system to eliminate node with known values     c
c clrow    : clear a row of a CSR matrix                               c
c lctcsr   : locate the position of A(i,j) in CSR format               c
c----------------------------------------------------------------------c
      subroutine gen57pt(nx,ny,nz,al,mode,n,a,ja,ia,iau,rhs)
      integer ja(*),ia(*),iau(*), nx, ny, nz, mode, n
      real*8 a(*), rhs(*), al(6)
c-----------------------------------------------------------------------
c On entry:
c
c nx      = number of grid points in x direction
c ny	  = number of grid points in y direction
c nz	  = number of grid points in z direction
c al      = array of size 6, carries the coefficient alpha of the
c           boundary conditions
c mode    = what to generate:
c           < 0 : generate the graph only,
c           = 0 : generate the matrix,
c           > 0 : generate the matrix and the right-hand side.
c
c On exit:
c
c n       = number of nodes with unknown values, ie number of rows
c           in the matrix
c
c a,ja,ia = resulting matrix in row-sparse format
c
c iau     = integer*n, containing the poisition of the diagonal element
c           in the a, ja, ia structure
c
c rhs     = the right-hand side
c
c External functions needed (must be supplied by caller)
c     afun, bfun, cfun, dfun, efun, ffun, gfun, hfun
c     betfun, gamfun
c They have the following prototype:
c     real*8 function xfun(x, y, z)
c     real*8 x, y, z
c-----------------------------------------------------------------------
c This subroutine computes the sparse matrix in compressed sparse row
c format for the elliptic equation:
c       d    du    d    du    d    du      du     du     du
c L u = --(A --) + --(B --) + --(C --) + D -- + E -- + F -- + G u = H u
c       dx   dx    dy   dy    dz   dz      dx     dy     dz
c
c with general Mixed Boundary conditions, on a rectangular 1-D,
c 2-D or 3-D grid using 2nd order centered difference schemes.
c
c The functions a, b, ..., g, h are known through the
c as afun, bfun, ..., gfun, hfun in this subroutine.
c NOTE: To obtain the correct matrix, any function that is not
c needed should be set to zero.  For example for two-dimensional
c problems, nz should be set to 1 and the functions cfun and ffun
c should be zero functions.
c
c The Boundary condition is specified in the following form:
c           du
c     alpha -- + beta u = gamma
c           dn
c Where alpha is constant at each side of the boundary surfaces.  Alpha
c is represented by parameter al.  It is expected to an array that
c contains enough elements to specify the boundaries for the problem,
c 1-D case needs two elements, 2-D needs 4 and 3-D needs 6.  The order
c of the boundaries in the array is left(west), right(east),
c bottom(south), top(north), front, rear.  Beta and gamma are functions
c of type real with three arguments x, y, z.  These two functions are
c known subroutine 'addbc' as betfun and gamfun.  They should following
c the same notion as afun ... hfun.  For more restriction on afun ...
c hfun, please read the documentation follows the subroutine 'getsten',
c and, for more on betfun and gamfun, please refer to the documentation
c under subroutine 'fdaddbc'.
c
c The nodes are ordered using natural ordering, first x direction, then
c y, then z.  The mesh size h is uniform and determined by grid points
c in the x-direction.
c
c The domain specified for the problem is [0 .ge. x .ge. 1],
c [0 .ge. y .ge. (ny-1)*h] and [0 .ge. z .ge. (nz-1)*h], where h is
c 1 / (nx-1).  Thus if non-Dirichlet boundary condition is specified,
c the mesh will have nx points along the x direction, ny along y and
c nz along z.  For 1-D case, both y and z value are assumed to zero
c when calling relavent functions that have three parameters.
c Similarly, for 2-D case, z is assumed to be zero.
c
c About the expectation of nx, ny and nz:
c nx is required to be .gt. 1 always;
c if the second dimension is present in the problem, then ny should be
c .gt. 1, else 1;
c if the third dimension is present in the problem, nz .gt. 1, else 1.
c when ny is 1, nz must be 1.
c-----------------------------------------------------------------------
c
c     stencil [1:7] has the following meaning:
c
c     center point = stencil(1)
c     west point = stencil(2)
c     east point = stencil(3)
c     south point = stencil(4)
c     north point = stencil(5)
c     front point = stencil(6)
c     back point = stencil(7)
c
c     al[1:6] carry the coefficient alpha in the similar order
c
c     west  side = al(1)
c     east  side = al(2)
c     south side = al(3)
c     north side = al(4)
c     front side = al(5)
c     back  side = al(6)
c
c                           al(4)
c                           st(5)
c                            |
c                            |
c                            |           al(6)
c                            |          .st(7)
c                            |     .
c         al(1)              | .             al(2)
c         st(2) ----------- st(1) ---------- st(3)
c                       .    |
c                   .        |
c               .            |
c            st(6)           |
c            al(5)           |
c                            |
c                           st(4)
c                           al(3)
c
c-------------------------------------------------------------------
c     some constants
c
      real*8 one
      parameter (one=1.0D0)
c
c     local variables
c
      integer ix, iy, iz, kx, ky, kz, node, iedge
      real*8  r, h, stencil(7)
      logical value, genrhs
c
c     nx has to be larger than 1
c
      if (nx.le.1) return
      h = one / dble(nx-1)
c
c     the mode
c
      value = (mode.ge.0)
      genrhs = (mode.gt.0)
c
c     first generate the whole matrix as if the boundary condition does
c     not exist
c
      kx = 1
      ky = nx
      kz = nx*ny
      iedge = 1
      node = 1
      do 100 iz = 1,nz
         do 90 iy = 1,ny
            do 80 ix = 1,nx
               ia(node) = iedge
c
c     compute the stencil at the current node
c
               if (value) call
     &              getsten(ny,nz,mode,ix-1,iy-1,iz-1,stencil,h,r)
c     west
               if (ix.gt.1) then
                  ja(iedge)=node-kx
                  if (value) a(iedge) = stencil(2)
                  iedge=iedge + 1
               end if
c     south
               if (iy.gt.1) then
                  ja(iedge)=node-ky
                  if (value) a(iedge) = stencil(4)
                  iedge=iedge + 1
               end if
c     front plane
               if (iz.gt.1) then
                  ja(iedge)=node-kz
                  if (value) a(iedge) = stencil(6)
                  iedge=iedge + 1
               endif
c     center node
               ja(iedge) = node
               iau(node) = iedge
               if (value) a(iedge) = stencil(1)
               iedge = iedge + 1
c     east
               if (ix.lt.nx) then
                  ja(iedge)=node+kx
                  if (value) a(iedge) = stencil(3)
                  iedge=iedge + 1
               end if
c     north
               if (iy.lt.ny) then
                  ja(iedge)=node+ky
                  if (value) a(iedge) = stencil(5)
                  iedge=iedge + 1
               end if
c     back plane
               if (iz.lt.nz) then
                  ja(iedge)=node+kz
                  if (value) a(iedge) = stencil(7)
                  iedge=iedge + 1
               end if
c     the right-hand side
               if (genrhs) rhs(node) = r
               node=node+1
 80         continue
 90      continue
 100  continue
      ia(node)=iedge
c
c     Add in the boundary conditions
c
      call fdaddbc(nx,ny,nz,a,ja,ia,iau,rhs,al,h)
c
c     eliminate the boudary nodes from the matrix
c
      call fdreduce(nx,ny,nz,al,n,a,ja,ia,iau,rhs,stencil)
c
c     done
c
      return
c-----end-of-gen57pt----------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine getsten (ny,nz,mode,kx,ky,kz,stencil,h,rhs)
      integer ny,nz,mode,kx,ky,kz
      real*8 stencil(*),h,rhs,afun,bfun,cfun,dfun,efun,ffun,gfun,hfun
      external afun,bfun,cfun,dfun,efun,ffun,gfun,hfun
c-----------------------------------------------------------------------
c     This subroutine calculates the correct stencil values for
c     centered difference discretization of the elliptic operator
c     and the right-hand side
c
c L u = delx( A delx u ) + dely ( B dely u) + delz ( C delz u ) +
c	delx ( D u ) + dely (E u) + delz( F u ) + G u = H
c
c   For 2-D problems the discretization formula that is used is:
c
c h**2 * Lu == A(i+1/2,j)*{u(i+1,j) - u(i,j)} +
c	       A(i-1/2,j)*{u(i-1,j) - u(i,j)} +
c              B(i,j+1/2)*{u(i,j+1) - u(i,j)} +
c              B(i,j-1/2)*{u(i,j-1) - u(i,j)} +
c              (h/2)*D(i,j)*{u(i+1,j) - u(i-1,j)} +
c              (h/2)*E(i,j)*{u(i,j+1) - u(i,j-1)} +
c              (h/2)*E(i,j)*{u(i,j+1) - u(i,j-1)} +
c              (h**2)*G(i,j)*u(i,j)
c-----------------------------------------------------------------------
c     some constants
c
      real*8 zero, half
      parameter (zero=0.0D0,half=0.5D0)
c
c     local variables
c
      integer k
      real*8 hhalf,cntr, x, y, z, coeff
c
c     if mode < 0, we shouldn't have come here
c
      if (mode .lt. 0) return
c
      do 200 k=1,7
         stencil(k) = zero
 200  continue
c
      hhalf = h*half
      x = h*dble(kx)
      y = h*dble(ky)
      z = h*dble(kz)
      cntr = zero
c     differentiation wrt x:
      coeff = afun(x+hhalf,y,z)
      stencil(3) = stencil(3) + coeff
      cntr = cntr + coeff
c
      coeff = afun(x-hhalf,y,z)
      stencil(2) = stencil(2) + coeff
      cntr = cntr + coeff
c
      coeff = dfun(x,y,z)*hhalf
      stencil(3) = stencil(3) + coeff
      stencil(2) = stencil(2) - coeff
      if (ny .le. 1) goto 99
c
c     differentiation wrt y:
c
      coeff = bfun(x,y+hhalf,z)
      stencil(5) = stencil(5) + coeff
      cntr = cntr + coeff
c
      coeff = bfun(x,y-hhalf,z)
      stencil(4) = stencil(4) + coeff
      cntr = cntr + coeff
c
      coeff = efun(x,y,z)*hhalf
      stencil(5) = stencil(5) + coeff
      stencil(4) = stencil(4) - coeff
      if (nz .le. 1) goto 99
c
c differentiation wrt z:
c
      coeff = cfun(x,y,z+hhalf)
      stencil(7) = stencil(7) + coeff
      cntr = cntr + coeff
c
      coeff = cfun(x,y,z-hhalf)
      stencil(6) = stencil(6) + coeff
      cntr = cntr + coeff
c
      coeff = ffun(x,y,z)*hhalf
      stencil(7) = stencil(7) + coeff
      stencil(6) = stencil(6) - coeff
c
c contribution from function G:
c
 99   coeff = gfun(x,y,z)
      stencil(1) = h*h*coeff - cntr
c
c     the right-hand side
c
      if (mode .gt. 0) rhs = h*h*hfun(x,y,z)
c
      return
c------end-of-getsten---------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine gen57bl (nx,ny,nz,nfree,na,n,a,ja,ia,iau,stencil)
c     implicit real*8 (a-h,o-z)
      integer ja(*),ia(*),iau(*),nx,ny,nz,nfree,na,n
      real*8 a(na,1), stencil(7,1)
c--------------------------------------------------------------------
c This subroutine computes the sparse matrix in compressed
c format for the elliptic operator
c
c L u = delx( a . delx u ) + dely ( b . dely u) + delz ( c . delz u ) +
c	delx ( d . u ) + dely (e . u) + delz( f . u ) + g . u
c
c Here u is a vector of nfree componebts and each of the functions
c a, b, c, d, e, f, g   is an (nfree x nfree) matrix depending of
c the coordinate (x,y,z).
c with Dirichlet Boundary conditions, on a rectangular 1-D,
c 2-D or 3-D grid using centered difference schemes.
c
c The functions a, b, ..., g are known through the
c subroutines  afunbl, bfunbl, ..., gfunbl. (user supplied) .
c
c uses natural ordering, first x direction, then y, then z
c mesh size h is uniform and determined by grid points
c in the x-direction.
c
c The output matrix is in Block -- Sparse Row format.
c
c--------------------------------------------------------------------
c parameters:
c-------------
c Input:
c ------
c nx      = number of points in x direction
c ny	  = number of points in y direction
c nz	  = number of points in z direction
c nfree   = number of degrees of freedom per point
c na	  = first dimension of array a as declared in calling
c           program. Must be .ge. nfree**2
c
c Output:
c ------
c n	  = dimension of matrix (output)
c
c a, ja, ia = resulting matrix in  Block Sparse Row format
c           a(1:nfree**2, j ) contains a nonzero block and ja(j)
c           contains the (block) column number of this block.
c           the block dimension of the matrix is n (output) and
c           therefore the total number of (scalar) rows is n x nfree.
c
c iau     = integer*n containing the position of the diagonal element
c           in the a, ja, ia structure
c
c Work space:
c------------
c stencil =  work array of size (7,nfree**2) [stores local stencils]
c
c--------------------------------------------------------------------
c
c     stencil (1:7,*) has the following meaning:
c
c     center point = stencil(1)
c     west point   = stencil(2)
c     east point   = stencil(3)
c     south point  = stencil(4)
c     north point  = stencil(5)
c     front point  = stencil(6)
c     back point   = stencil(7)
c
c
c                           st(5)
c                            |
c                            |
c                            |
c                            |          .st(7)
c                            |     .
c                            | .
c         st(2) ----------- st(1) ---------- st(3)
c                       .    |
c                   .        |
c               .            |
c            st(6)           |
c                            |
c                            |
c                           st(4)
c
c-------------------------------------------------------------------
c     some constants
c
      real*8 one
      parameter (one=1.0D0)
c
c     local variables
c
      integer iedge,ix,iy,iz,k,kx,ky,kz,nfree2,node
      real*8  h
c
      h = one/dble(nx+1)
      kx = 1
      ky = nx
      kz = nx*ny
      nfree2 = nfree*nfree
      iedge = 1
      node = 1
      do 100 iz = 1,nz
         do 90 iy = 1,ny
            do 80 ix = 1,nx
               ia(node) = iedge
               call bsten(ny,nz,ix,iy,iz,nfree,stencil,h)
c     west
               if (ix.gt.1) then
                  ja(iedge)=node-kx
                  do 4 k=1,nfree2
                     a(k,iedge) = stencil(2,k)
 4                  continue
                  iedge=iedge + 1
               end if
c     south
               if (iy.gt.1) then
                  ja(iedge)=node-ky
                  do 5 k=1,nfree2
                     a(k,iedge) = stencil(4,k)
 5                  continue
                  iedge=iedge + 1
               end if
c     front plane
               if (iz.gt.1) then
                  ja(iedge)=node-kz
                  do 6 k=1,nfree2
                     a(k,iedge) = stencil(6,k)
 6                  continue
                  iedge=iedge + 1
               endif
c     center node
               ja(iedge) = node
               iau(node) = iedge
               do 7 k=1,nfree2
                  a(k,iedge) = stencil(1,k)
 7             continue
               iedge = iedge + 1
c     -- upper part
c     east
               if (ix.lt.nx) then
                  ja(iedge)=node+kx
                  do 8 k=1,nfree2
                     a(k,iedge) = stencil(3,k)
 8                  continue
                  iedge=iedge + 1
               end if
c     north
               if (iy.lt.ny) then
                  ja(iedge)=node+ky
                  do 9 k=1,nfree2
                     a(k,iedge) = stencil(5,k)
 9                  continue
                  iedge=iedge + 1
               end if
c     back plane
               if (iz.lt.nz) then
                  ja(iedge)=node+kz
                  do 10 k=1,nfree2
                     a(k,iedge) = stencil(7,k)
 10                  continue
                  iedge=iedge + 1
               end if
c------next node -------------------------
               node=node+1
 80         continue
 90      continue
 100  continue
c
c     -- new version of BSR -- renumbering removed.
c     change numbering of nodes so that each ja(k) will contain the
c     actual column number in the original matrix of entry (1,1) of each
c     block (k).
c      do 101 k=1,iedge-1
c         ja(k) = (ja(k)-1)*nfree+1
c 101  continue
c
c      n = (node-1)*nfree
      n = node-1
      ia(node)=iedge
      return
c--------------end-of-gen57bl-------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine bsten (ny,nz,kx,ky,kz,nfree,stencil,h)
c-----------------------------------------------------------------------
c     This subroutine calcultes the correct block-stencil values for
c     centered difference discretization of the elliptic operator
c     (block version of stencil)
c
c L u = delx( a delx u ) + dely ( b dely u) + delz ( c delz u ) +
c       d delx ( u ) + e dely (u) + f delz( u ) + g u
c
c   For 2-D problems the discretization formula that is used is:
c
c h**2 * Lu == a(i+1/2,j)*{u(i+1,j) - u(i,j)} +
c              a(i-1/2,j)*{u(i-1,j) - u(i,j)} +
c              b(i,j+1/2)*{u(i,j+1) - u(i,j)} +
c              b(i,j-1/2)*{u(i,j-1) - u(i,j)} +
c              (h/2)*d(i,j)*{u(i+1,j) - u(i-1,j)} +
c              (h/2)*e(i,j)*{u(i,j+1) - u(i,j-1)} +
c              (h/2)*e(i,j)*{u(i,j+1) - u(i,j-1)} +
c              (h**2)*g(i,j)*u(i,j)
c-----------------------------------------------------------------------
c     some constants
c
      real*8  zero,half
      parameter(zero=0.0D0,half=0.5D0)
c
c     local variables
c
      integer i,k,kx,ky,kz,nfree,nfree2,ny,nz
      real*8 stencil(7,*), cntr(225), coeff(225),h,h2,hhalf,x,y,z
c------------
      if (nfree .gt. 15) then
         print *, ' ERROR ** nfree too large '
         stop
      endif
c
      nfree2 = nfree*nfree
      do 200 k=1, nfree2
         cntr(k) = zero
         do 199 i=1,7
            stencil(i,k) = zero
 199     continue
 200  continue
c------------
      hhalf = h*half
      h2 = h*h
      x = h*dble(kx)
      y = h*dble(ky)
      z = h*dble(kz)
c differentiation wrt x:
      call afunbl(nfree,x+hhalf,y,z,coeff)
      do 1 k=1, nfree2
      stencil(3,k) = stencil(3,k) + coeff(k)
      cntr(k) = cntr(k) + coeff(k)
 1    continue
c
      call afunbl(nfree,x-hhalf,y,z,coeff)
      do 2 k=1, nfree2
         stencil(2,k) = stencil(2,k) + coeff(k)
         cntr(k) = cntr(k) + coeff(k)
 2    continue
c
      call dfunbl(nfree,x,y,z,coeff)
      do 3 k=1, nfree2
         stencil(3,k) = stencil(3,k) + coeff(k)*hhalf
         stencil(2,k) = stencil(2,k) - coeff(k)*hhalf
 3    continue
      if (ny .le. 1) goto 99
c
c differentiation wrt y:
c
      call bfunbl(nfree,x,y+hhalf,z,coeff)
      do 4 k=1,nfree2
         stencil(5,k) = stencil(5,k) + coeff(k)
         cntr(k) = cntr(k) + coeff(k)
 4    continue
c
      call bfunbl(nfree,x,y-hhalf,z,coeff)
      do 5 k=1, nfree2
         stencil(4,k) = stencil(4,k) + coeff(k)
         cntr(k) = cntr(k) + coeff(k)
 5    continue
c
      call efunbl(nfree,x,y,z,coeff)
      do 6 k=1, nfree2
         stencil(5,k) = stencil(5,k) + coeff(k)*hhalf
         stencil(4,k) = stencil(4,k) - coeff(k)*hhalf
 6    continue
      if (nz .le. 1) goto 99
c
c differentiation wrt z:
c
      call cfunbl(nfree,x,y,z+hhalf,coeff)
      do 7 k=1, nfree2
         stencil(7,k) = stencil(7,k) + coeff(k)
         cntr(k) = cntr(k) + coeff(k)
 7    continue
c
      call cfunbl(nfree,x,y,z-hhalf,coeff)
      do 8 k=1, nfree2
         stencil(6,k) = stencil(6,k) + coeff(k)
         cntr(k) = cntr(k) + coeff(k)
 8    continue
c
      call ffunbl(nfree,x,y,z,coeff)
      do 9 k=1, nfree2
         stencil(7,k) = stencil(7,k) + coeff(k)*hhalf
         stencil(6,k) = stencil(6,k) - coeff(k)*hhalf
 9    continue
c
c discretization of  product by g:
c
 99   call gfunbl(nfree,x,y,z,coeff)
      do 10 k=1, nfree2
         stencil(1,k) = h2*coeff(k) - cntr(k)
 10   continue
c
      return
c------------end of bsten-----------------------------------------------
c-----------------------------------------------------------------------
      end
      subroutine fdreduce(nx,ny,nz,alpha,n,a,ja,ia,iau,rhs,stencil)
      implicit none
      integer nx,ny, nz, n, ia(*), ja(*), iau(*)
      real*8  alpha(*), a(*), rhs(*), stencil(*)
c-----------------------------------------------------------------------
c This subroutine tries to reduce the size of the matrix by looking
c for Dirichlet boundary conditions at each surface and solve the boundary
c value and modify the right-hand side of related nodes, then clapse all
c the boundary nodes.
c-----------------------------------------------------------------------
c     parameters
c
      real*8   zero
      parameter(zero=0.0D0)
c
c     local variables
c
      integer  i,j,k,kx,ky,kz,lx,ux,ly,uy,lz,uz,node,nbnode,lk,ld,iedge
      real*8   val
      integer  lctcsr
      external lctcsr
c
c     The first half of this subroutine will try to change the right-hand
c     side of all the nodes that has a neighbor with Dirichlet boundary
c     condition, since in this case the value of the boundary point is
c     known.
c     Then in the second half, we will try to eliminate the boundary
c     points with known values (with Dirichlet boundary condition).
c
      kx = 1
      ky = nx
      kz = nx*ny
      lx = 1
      ux = nx
      ly = 1
      uy = ny
      lz = 1
      uz = nz
c
c     Here goes the first part. ----------------------------------------
c
c     the left (west) side
c
      if (alpha(1) .eq. zero) then
         lx = 2
         do 10 k = 1, nz
            do 11 j = 1, ny
               node = (k-1)*kz + (j-1)*ky + 1
               nbnode = node + kx
               lk = lctcsr(nbnode, node, ja, ia)
               ld = iau(node)
               val = rhs(node)/a(ld)
c     modify the rhs
               rhs(nbnode) = rhs(nbnode) - a(lk)*val
 11         continue
 10      continue
      endif
c
c     right (east) side
c
      if (alpha(2) .eq. zero) then
         ux = nx - 1
         do 20 k = 1, nz
            do 21 j = 1, ny
               node = (k-1)*kz + (j-1)*ky + nx
               nbnode = node - kx
               lk = lctcsr(nbnode, node, ja, ia)
               ld = iau(node)
               val = rhs(node)/a(ld)
c     modify the rhs
               rhs(nbnode) = rhs(nbnode) - a(lk)*val
 21         continue
 20      continue
      endif
c
c     if it's only 1-D, skip the following part
c
      if (ny .le. 1) goto 100
c
c     the bottom (south) side
c
      if (alpha(3) .eq. zero) then
         ly = 2
         do 30 k = 1, nz
            do 31 i = lx, ux
               node = (k-1)*kz + i
               nbnode = node + ky
               lk = lctcsr(nbnode, node, ja, ia)
               ld = iau(node)
               val = rhs(node)/a(ld)
c     modify the rhs
               rhs(nbnode) = rhs(nbnode) - a(lk)*val
 31         continue
 30      continue
      endif
c
c     top (north) side
c
      if (alpha(4) .eq. zero) then
         uy = ny - 1
         do 40 k = 1, nz
            do 41 i = lx, ux
               node = (k-1)*kz + i + (ny-1)*ky
               nbnode = node - ky
               lk = lctcsr(nbnode, node, ja, ia)
               ld = iau(node)
               val = rhs(node)/a(ld)
c     modify the rhs
               rhs(nbnode) = rhs(nbnode) - a(lk)*val
 41         continue
 40      continue
      endif
c
c     if only 2-D skip the following section on z
c
      if (nz .le. 1) goto 100
c
c     the front surface
c
      if (alpha(5) .eq. zero) then
         lz = 2
         do 50 j = ly, uy
            do 51 i = lx,  ux
               node = (j-1)*ky + i
               nbnode = node + kz
               lk = lctcsr(nbnode, node, ja, ia)
               ld = iau(node)
               val = rhs(node)/a(ld)
c     modify the rhs
               rhs(nbnode) = rhs(nbnode) - a(lk)*val
 51         continue
 50      continue
      endif
c
c     rear surface
c
      if (alpha(6) .eq. zero) then
         uz = nz - 1
         do 60 j = ly, uy
            do 61 i = lx, ux
               node = (nz-1)*kz + (j-1)*ky + i
               nbnode = node - kz
               lk = lctcsr(nbnode, node, ja, ia)
               ld = iau(node)
               val = rhs(node)/a(ld)
c     modify the rhs
               rhs(nbnode) = rhs(nbnode) - a(lk)*val
 61         continue
 60      continue
      endif
c
c     now the second part ----------------------------------------------
c
c     go through all the actual nodes with unknown values, collect all
c     of them to form a new matrix in compressed sparse row format.
c
 100  kx = 1
      ky = ux - lx + 1
      kz = (uy - ly + 1) * ky
      node = 1
      iedge = 1
      do 80 k = lz, uz
         do 81 j = ly, uy
            do 82 i = lx, ux
c
c     the corresponding old node number
               nbnode = ((k-1)*ny + j-1)*nx + i
c
c     copy the row into local stencil, copy is done is the exact
c     same order as the stencil is written into array a
               lk = ia(nbnode)
               if (i.gt.1) then
                  stencil(2) = a(lk)
                  lk = lk + 1
               end if
               if (j.gt.1) then
                  stencil(4) = a(lk)
                  lk = lk + 1
               end if
               if (k.gt.1) then
                  stencil(6) = a(lk)
                  lk = lk + 1
               end if
               stencil(1) = a(lk)
               lk = lk + 1
               if (i.lt.nx) then
                  stencil(3) = a(lk)
                  lk = lk + 1
               endif
               if (j.lt.ny) then
                  stencil(5) = a(lk)
                  lk = lk + 1
               end if
               if (k.lt.nz) stencil(7) = a(lk)
c
c     first the ia pointer -- points to the beginning of each row
               ia(node) = iedge
c
c     move the values from the local stencil to the new matrix
c
c     the neighbor on the left (west)
               if (i.gt.lx) then
                  ja(iedge)=node-kx
                  a(iedge) =stencil(2)
                  iedge=iedge + 1
               end if
c     the neighbor below (south)
               if (j.gt.ly) then
                  ja(iedge)=node-ky
                  a(iedge)=stencil(4)
                  iedge=iedge + 1
               end if
c     the neighbor in the front
               if (k.gt.lz) then
                  ja(iedge)=node-kz
                  a(iedge)=stencil(6)
                  iedge=iedge + 1
               endif
c     center node (itself)
               ja(iedge) = node
               iau(node) = iedge
               a(iedge) = stencil(1)
               iedge = iedge + 1
c     the neighbor to the right (east)
               if (i.lt.ux) then
                  ja(iedge)=node+kx
                  a(iedge)=stencil(3)
                  iedge=iedge + 1
               end if
c     the neighbor above (north)
               if (j.lt.uy) then
                  ja(iedge)=node+ky
                  a(iedge)=stencil(5)
                  iedge=iedge + 1
               end if
c     the neighbor at the back
               if (k.lt.uz) then
                  ja(iedge)=node+kz
                  a(iedge)=stencil(7)
                  iedge=iedge + 1
               end if
c     the right-hand side
               rhs(node) = rhs(nbnode)
c------next node -------------------------
               node=node+1
c
 82         continue
 81      continue
 80   continue
c
      ia(node) = iedge
c
c     the number of nodes in the final matrix is stored in n
c
      n = node - 1
      return
c-----------------------------------------------------------------------
      end
c-----end of fdreduce-----------------------------------------------------
c-----------------------------------------------------------------------
      subroutine fdaddbc(nx,ny,nz,a,ja,ia,iau,rhs,al,h)
      integer nx, ny, nz, ia(nx*ny*nz), ja(7*nx*ny*nz), iau(nx*ny*nz)
      real*8  h, al(6), a(7*nx*ny*nz), rhs(nx*ny*nz)
c-----------------------------------------------------------------------
c This subroutine will add the boundary condition to the linear system
c consutructed without considering the boundary conditions
c
c The Boundary condition is specified in the following form:
c           du
c     alpha -- + beta u = gamma
c           dn
c Alpha is stored in array AL.  The six side of the boundary appares
c in AL in the following order: left(west), right(east), bottom(south),
c top(north), front, back(rear). (see also the illustration in gen57pt)
c Beta and gamma appears as the functions, betfun and gamfun.
c They have the following prototype
c
c real*8 function xxxfun(x, y, z)
c real*8 x, y, z
c
c where x, y, z are vales in the range of [0, 1][0, (ny-1)*h]
c [0, (nz-1)*h]
c
c At the corners or boundary lines, the boundary conditions are applied
c in the follow order:
c 1) if one side is Dirichlet boundary condition, the Dirichlet boundary
c    condition is used;
c 2) if more than one sides are Dirichlet, the Direichlet condition
c    specified for X direction boundary will overwrite the one specified
c    for Y direction boundary which in turn has priority over Z
c     direction boundaries.
c 3) when all sides are non-Dirichlet, the average values are used.
c-----------------------------------------------------------------------
c     some constants
c
      real*8   half,zero,one,two
      parameter(half=0.5D0,zero=0.0D0,one=1.0D0,two=2.0D0)
c
c     local variables
c
      character*2 side
      integer  i,j,k,kx,ky,kz,node,nbr,ly,uy,lx,ux
      real*8   coeff, ctr, hhalf, x, y, z
      real*8   afun, bfun, cfun, dfun, efun, ffun
c         , gfun, hfun
      external afun, bfun, cfun, dfun, efun, ffun
c     external  gfun, hfun
      real*8   betfun, gamfun
      integer  lctcsr
      external lctcsr, betfun, gamfun
c
      hhalf = half * h
      kx = 1
      ky = nx
      kz = nx*ny
c
c     In 3-D case, we need to go through all 6 faces one by one. If
c     the actual dimension is lower, test on ny is performed first.
c     If ny is less or equals to 1, then the value of nz is not
c     checked.
c-----
c     the surface on the left (west) side
c     Concentrate on the contribution from the derivatives related to x,
c     The terms with derivative of x was assumed to be:
c
c     a(3/2,j,k)*[u(2,j,k)-u(1,j,k)] + a(1/2,j,k)*[u(0,j,k)-u(1,j,k)] +
c     h*d(1,j,k)*[u(2,j,k)-u(0,j,k)]/2
c
c     But they actually are:
c
c     2*{a(3/2,j,k)*[u(2,j,k)-u(1,j,k)] -
c     h*a(1,j,k)*[beta*u(1,j,k)-gamma]/alpha]} +
c     h*h*d(1,j,k)*[beta*u(1,j,k)-gamma]/alpha
c
c     Therefore, in terms of local stencil the right neighbor of a node
c     should be changed to 2*a(3/2,j,k),
c     The matrix never contains the left neighbor on this border, nothing
c     needs to be done about it.
c     The following terms should be added to the center stencil:
c     -a(3/2,j,k) + a(1/2,j,k) + [h*d(1,j,k)-2*a(1,j,k)]*h*beta/alpha
c
c     And these terms should be added to the corresponding right-hand side
c     [h*d(1,j,k)-2*a(1,j,k)]*h*gamma/alpha
c
c     Obviously, the formula do not apply for the Dirichlet Boundary
c     Condition, where alpha will be zero. In that case, we simply set
c     all the elements in the corresponding row to zero(0), then let
c     the diagonal element be beta, and the right-hand side be gamma.
c     Thus the value of u at that point will be set. Later on point
c     like this will be removed from the matrix, since they are of
c     know value before solving the system.(not done in this subroutine)
c
      x = zero
      side = 'x1'
      do 20 k = 1, nz
         z = (k-1)*h
         do 21 j = 1, ny
            y = (j-1)*h
            node = 1+(j-1)*ky+(k-1)*kz
c
c     check to see if it's Dirichlet Boundary condition here
c
            if (al(1) .eq. zero) then
               call clrow(node, a, ia)
               a(iau(node)) = betfun(side,x,y,z)
               rhs(node) = gamfun(side,x,y,z)
            else
c
c     compute the terms formulated above to modify the matrix.
c
c     the right neighbor is stroed in nbr'th posiiton in the a
               nbr = lctcsr(node, node+kx, ja, ia)
c
               coeff = two*afun(x,y,z)
               ctr = (h*dfun(x,y,z) - coeff)*h/al(1)
               rhs(node) = rhs(node) + ctr * gamfun(side,x,y,z)
               ctr = afun(x-hhalf,y,z) + ctr * betfun(side,x,y,z)
               coeff = afun(x+hhalf,y,z)
               a(iau(node)) = a(iau(node)) - coeff + ctr
               a(nbr) = two*coeff
            end if
 21      continue
 20   continue
c
c     the right (east) side boudary, similarly, the contirbution from
c     the terms containing the derivatives of x were assumed to be
c
c     a(nx+1/2,j,k)*[u(nx+1,j,k)-u(nx,j,k)] +
c     a(nx-1/2,j,k)*[u(nx-1,j,k)-u(nx,j,k)] +
c     d(nx,j,k)*[u(nx+1,j,k)-u(nx-1,j,k)]*h/2
c
c     Actualy they are:
c
c     2*{h*a(nx,j,k)*[gamma-beta*u(nx,j,k)]/alpha +
c     a(nx-1/2,j,k)*[u(nx-1,j,k)-u(nx,j,k)]} +
c     h*h*d(nx,j,k)*[gamma-beta*u(nx,j,k)]/alpha
c
c     The left stencil has to be set to 2*a(nx-1/2,j,k)
c
c     The following terms have to be added to the center stencil:
c
c     -a(nx-1/2,j,k)+a(nx+1/2,j,k)-[2*a(nx,j,k)+h*d(nx,j,k)]*beta/alpha
c
c     The following terms have to be added to the right-hand side:
c
c     -[2*a(nx,j,k)+h*d(nx,j,k)]*h*gamma/alpha
c
      x = one
      side = 'x2'
      do 22 k = 1, nz
         z = (k-1)*h
         do 23 j = 1, ny
            y = (j-1)*h
            node = (k-1)*kz + j*ky
c
            if (al(2) .eq. zero) then
               call clrow(node, a, ia)
               a(iau(node)) = betfun(side,x,y,z)
               rhs(node) = gamfun(side,x,y,z)
            else
               nbr = lctcsr(node, node-kx, ja, ia)
c
               coeff = two*afun(x,y,z)
               ctr = (coeff + h*dfun(x,y,z))*h/al(2)
               rhs(node) = rhs(node) - ctr * gamfun(side,x,y,z)
               ctr = afun(x+hhalf,y,z) - ctr * betfun(side,x,y,z)
               coeff = afun(x-hhalf,y,z)
               a(iau(node)) = a(iau(node)) - coeff + ctr
               a(nbr) = two*coeff
            end if
 23      continue
 22   continue
c
c     If only one dimension, return now
c
      if (ny .le. 1) return
c
c     the bottom (south) side suface, This similar to the situation
c     with the left side, except all the function and realted variation
c     should be on the y.
c
c     These two block if statment here is to resolve the possible conflict
c     of assign the boundary value differently by different side of the
c     Dirichlet Boundary Conditions. They ensure that the edges that have
c     be assigned a specific value will not be reassigned.
c
      if (al(1) .eq. zero) then
         lx = 2
      else
         lx = 1
      end if
      if (al(2) .eq. zero) then
         ux = nx-1
      else
         ux = nx
      end if
      y = zero
      side = 'y1'
      do 24 k = 1, nz
         z = (k-1)*h
         do 25 i = lx, ux
            x = (i-1)*h
            node = i + (k-1)*kz
c
            if (al(3) .eq. zero) then
               call clrow(node, a, ia)
               a(iau(node)) = betfun(side,x,y,z)
               rhs(node) = gamfun(side,x,y,z)
            else
               nbr = lctcsr(node, node+ky, ja, ia)
c
               coeff = two*bfun(x,y,z)
               ctr = (h*efun(x,y,z) - coeff)*h/al(3)
               rhs(node) = rhs(node) + ctr * gamfun(side,x,y,z)
               ctr = bfun(x,y-hhalf,z) + ctr * betfun(side,x,y,z)
               coeff = bfun(x,y+hhalf,z)
               a(iau(node)) = a(iau(node)) - coeff + ctr
               a(nbr) = two*coeff
            end if
 25      continue
 24   continue
c
c     The top (north) side, similar to the right side
c
      y = (ny-1) * h
      side = 'y2'
      do 26 k = 1, nz
         z = (k-1)*h
         do 27 i = lx, ux
            x = (i-1)*h
            node = (k-1)*kz+(ny-1)*ky + i
c
            if (al(4) .eq. zero) then
               call clrow(node, a, ia)
               a(iau(node)) = betfun(side,x,y,z)
               rhs(node) = gamfun(side,x,y,z)
            else
               nbr = lctcsr(node, node-ky, ja, ia)
c
               coeff = two*bfun(x,y,z)
               ctr = (coeff + h*efun(x,y,z))*h/al(4)
               rhs(node) = rhs(node) - ctr * gamfun(side,x,y,z)
               ctr = bfun(x,y+hhalf,z) - ctr * betfun(side,x,y,z)
               coeff = bfun(x,y-hhalf,z)
               a(iau(node)) = a(iau(node)) - coeff + ctr
               a(nbr) = two*coeff
            end if
 27      continue
 26   continue
c
c     If only has two dimesion to work on, return now
c
      if (nz .le. 1) return
c
c     The front side boundary
c
c     If the edges of the surface has been decided by Dirichlet Boundary
c     Condition, then leave them alone.
c
      if (al(3) .eq. zero) then
         ly = 2
      else
         ly = 1
      end if
      if (al(4) .eq. zero) then
         uy = ny-1
      else
         uy = ny
      end if
c
      z = zero
      side = 'z1'
      do 28 j = ly, uy
         y = (j-1)*h
         do 29 i = lx, ux
            x = (i-1)*h
            node = i + (j-1)*ky
c
            if (al(5) .eq. zero) then
               call clrow(node, a, ia)
               a(iau(node)) = betfun(side,x,y,z)
               rhs(node) = gamfun(side,x,y,z)
            else
               nbr = lctcsr(node, node+kz, ja, ia)
c
               coeff = two*cfun(x,y,z)
               ctr = (h*ffun(x,y,z) - coeff)*h/al(5)
               rhs(node) = rhs(node) + ctr * gamfun(side,x,y,z)
               ctr = cfun(x,y,z-hhalf) + ctr * betfun(side,x,y,z)
               coeff = cfun(x,y,z+hhalf)
               a(iau(node)) = a(iau(node)) - coeff + ctr
               a(nbr) = two*coeff
            end if
 29      continue
 28   continue
c
c     Similiarly for the top side of the boundary suface
c
      z = (nz - 1) * h
      side = 'z2'
      do 30 j = ly, uy
         y = (j-1)*h
         do 31 i = lx, ux
            x = (i-1)*h
            node = (nz-1)*kz + (j-1)*ky + i
c
            if (al(6) .eq. zero) then
               call clrow(node, a, ia)
               a(iau(node)) = betfun(side,x,y,z)
               rhs(node) = gamfun(side,x,y,z)
            else
               nbr = lctcsr(node, node-kz, ja, ia)
c
               coeff = two*cfun(x,y,z)
               ctr = (coeff + h*ffun(x,y,z))*h/al(6)
               rhs(node) = rhs(node) - ctr * gamfun(side,x,y,z)
               ctr = cfun(x,y,z+hhalf) - ctr * betfun(side,x,y,z)
               coeff = cfun(x,y,z-hhalf)
               a(iau(node)) = a(iau(node)) - coeff + ctr
               a(nbr) = two*coeff
            end if
 31      continue
 30   continue
c
c     all set
c
      return
c-----------------------------------------------------------------------
      end
c-----end of fdaddbc----------------------------------------------------
c-----------------------------------------------------------------------
      subroutine clrow(i, a, ia)
      integer i, ia(*), k
      real *8 a(*)
c-----------------------------------------------------------------------
c     clear the row i to all zero, but still keep the structure of the
c     CSR matrix
c-----------------------------------------------------------------------
      do 10 k = ia(i), ia(i+1)-1
         a(k) = 0.0D0
 10   continue
c
      return
c-----end of clrow------------------------------------------------------
      end
c-----------------------------------------------------------------------
      function lctcsr(i,j,ja,ia)
      integer lctcsr, i, j, ja(*), ia(*), k
c-----------------------------------------------------------------------
c     locate the position of a matrix element in a CSR format
c     returns -1 if the desired element is zero
c-----------------------------------------------------------------------
      lctcsr = -1
      k = ia(i)
 10   if (k .lt. ia(i+1) .and. (lctcsr .eq. -1)) then
         if (ja(k) .eq. j) lctcsr = k
         k = k + 1
         goto 10
      end if
c
      return
c-----------------------------------------------------------------------
      end
c-----end of lctcsr-----------------------------------------------------