*DECK SSVDC
      SUBROUTINE SSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB,
     +   INFO)
C***BEGIN PROLOGUE  SSVDC
C***PURPOSE  Perform the singular value decomposition of a rectangular
C            matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D6
C***TYPE      SINGLE PRECISION (SSVDC-S, DSVDC-D, CSVDC-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX,
C             SINGULAR VALUE DECOMPOSITION
C***AUTHOR  Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     SSVDC is a subroutine to reduce a real NxP matrix X by orthogonal
C     transformations U and V to diagonal form.  The elements S(I) are
C     the singular values of X.  The columns of U are the corresponding
C     left singular vectors, and the columns of V the right singular
C     vectors.
C
C     On Entry
C
C         X         REAL(LDX,P), where LDX .GE. N.
C                   X contains the matrix whose singular value
C                   decomposition is to be computed.  X is
C                   destroyed by SSVDC.
C
C         LDX       INTEGER
C                   LDX is the leading dimension of the array X.
C
C         N         INTEGER
C                   N is the number of rows of the matrix X.
C
C         P         INTEGER
C                   P is the number of columns of the matrix X.
C
C         LDU       INTEGER
C                   LDU is the leading dimension of the array U.
C                   (See below).
C
C         LDV       INTEGER
C                   LDV is the leading dimension of the array V.
C                   (See below).
C
C         WORK      REAL(N)
C                   work is a scratch array.
C
C         JOB       INTEGER
C                   JOB controls the computation of the singular
C                   vectors.  It has the decimal expansion AB
C                   with the following meaning
C
C                        A .EQ. 0  Do not compute the left singular
C                                  vectors.
C                        A .EQ. 1  Return the N left singular vectors
C                                  in U.
C                        A .GE. 2  Return the first MIN(N,P) singular
C                                  vectors in U.
C                        B .EQ. 0  Do not compute the right singular
C                                  vectors.
C                        B .EQ. 1  Return the right singular vectors
C                                  in V.
C
C     On Return
C
C         S         REAL(MM), where MM=MIN(N+1,P).
C                   The first MIN(N,P) entries of S contain the
C                   singular values of X arranged in descending
C                   order of magnitude.
C
C         E         REAL(P).
C                   E ordinarily contains zeros.  However, see the
C                   discussion of INFO for exceptions.
C
C         U         REAL(LDU,K), where LDU .GE. N.  If JOBA .EQ. 1, then
C                                   K .EQ. N.  If JOBA .GE. 2 , then
C                                   K .EQ. MIN(N,P).
C                   U contains the matrix of right singular vectors.
C                   U is not referenced if JOBA .EQ. 0.  If N .LE. P
C                   or if JOBA .EQ. 2, then U may be identified with X
C                   in the subroutine call.
C
C         V         REAL(LDV,P), where LDV .GE. P.
C                   V contains the matrix of right singular vectors.
C                   V is not referenced if JOB .EQ. 0.  If P .LE. N,
C                   then V may be identified with X in the
C                   subroutine call.
C
C         INFO      INTEGER.
C                   the singular values (and their corresponding
C                   singular vectors) S(INFO+1),S(INFO+2),...,S(M)
C                   are correct (here M=MIN(N,P)).  Thus if
C                   INFO .EQ. 0, all the singular values and their
C                   vectors are correct.  In any event, the matrix
C                   B = TRANS(U)*X*V is the bidiagonal matrix
C                   with the elements of S on its diagonal and the
C                   elements of E on its super-diagonal (TRANS(U)
C                   is the transpose of U).  Thus the singular
C                   values of X and B are the same.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SDOT, SNRM2, SROT, SROTG, SSCAL, SSWAP
C***REVISION HISTORY  (YYMMDD)
C   790319  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SSVDC
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
C
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     1        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      REAL SDOT,T
      REAL B,C,CS,EL,EMM1,F,G,SNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST,
     1     ZTEST
      LOGICAL WANTU,WANTV
C***FIRST EXECUTABLE STATEMENT  SSVDC
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 30
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN(N-1,P)
      NRT = MAX(0,MIN(P-2,N))
      LU = MAX(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = SNRM2(N-L+1,X(L,L),1)
            IF (S(L) .EQ. 0.0E0) GO TO 10
               IF (X(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),X(L,L))
               CALL SSCAL(N-L+1,1.0E0/S(L),X(L,L),1)
               X(L,L) = 1.0E0 + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (S(L) .EQ. 0.0E0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = X(L,J)
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = SNRM2(P-L,E(LP1),1)
            IF (E(L) .EQ. 0.0E0) GO TO 80
               IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1))
               CALL SSCAL(P-L,1.0E0/E(L),E(LP1),1)
               E(LP1) = 1.0E0 + E(LP1)
   80       CONTINUE
            E(L) = -E(L)
            IF (LP1 .GT. N .OR. E(L) .EQ. 0.0E0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = 0.0E0
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL SAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL SAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
      M = MIN(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = 0.0E0
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = 0.0E0
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = 0.0E0
  180       CONTINUE
            U(J,J) = 1.0E0
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (S(L) .EQ. 0.0E0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -SDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL SAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL SSCAL(N-L+1,-1.0E0,U(L,L),1)
               U(L,L) = 1.0E0 + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = 0.0E0
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = 0.0E0
  260          CONTINUE
               U(L,L) = 1.0E0
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (E(L) .EQ. 0.0E0) GO TO 320
               DO 310 J = LP1, P
                  T = -SDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL SAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = 0.0E0
  330       CONTINUE
            V(L,L) = 1.0E0
  340    CONTINUE
  350 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  360 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
         IF (M .EQ. 0) GO TO 620
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 370
            INFO = M
            GO TO 620
  370    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 390 LL = 1, M
            L = M - LL
            IF (L .EQ. 0) GO TO 400
            TEST = ABS(S(L)) + ABS(S(L+1))
            ZTEST = TEST + ABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 380
               E(L) = 0.0E0
               GO TO 400
  380       CONTINUE
  390    CONTINUE
  400    CONTINUE
         IF (L .NE. M - 1) GO TO 410
            KASE = 4
         GO TO 480
  410    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 430 LLS = LP1, MP1
               LS = M - LLS + LP1
               IF (LS .EQ. L) GO TO 440
               TEST = 0.0E0
               IF (LS .NE. M) TEST = TEST + ABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1))
               ZTEST = TEST + ABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 420
                  S(LS) = 0.0E0
                  GO TO 440
  420          CONTINUE
  430       CONTINUE
  440       CONTINUE
            IF (LS .NE. L) GO TO 450
               KASE = 3
            GO TO 470
  450       CONTINUE
            IF (LS .NE. M) GO TO 460
               KASE = 1
            GO TO 470
  460       CONTINUE
               KASE = 2
               L = LS
  470       CONTINUE
  480    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (490,520,540,570), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  490    CONTINUE
            MM1 = M - 1
            F = E(M-1)
            E(M-1) = 0.0E0
            DO 510 KK = L, MM1
               K = MM1 - KK + L
               T1 = S(K)
               CALL SROTG(T1,F,CS,SN)
               S(K) = T1
               IF (K .EQ. L) GO TO 500
                  F = -SN*E(K-1)
                  E(K-1) = CS*E(K-1)
  500          CONTINUE
               IF (WANTV) CALL SROT(P,V(1,K),1,V(1,M),1,CS,SN)
  510       CONTINUE
         GO TO 610
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  520    CONTINUE
            F = E(L-1)
            E(L-1) = 0.0E0
            DO 530 K = L, M
               T1 = S(K)
               CALL SROTG(T1,F,CS,SN)
               S(K) = T1
               F = -SN*E(K)
               E(K) = CS*E(K)
               IF (WANTU) CALL SROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  530       CONTINUE
         GO TO 610
C
C        PERFORM ONE QR STEP.
C
  540    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = MAX(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)),
     1                    ABS(E(L)))
            SM = S(M)/SCALE
            SMM1 = S(M-1)/SCALE
            EMM1 = E(M-1)/SCALE
            SL = S(L)/SCALE
            EL = E(L)/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0
            C = (SM*EMM1)**2
            SHIFT = 0.0E0
            IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 550
               SHIFT = SQRT(B**2+C)
               IF (B .LT. 0.0E0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  550       CONTINUE
            F = (SL + SM)*(SL - SM) - SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 560 K = L, MM1
               CALL SROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = F
               F = CS*S(K) + SN*E(K)
               E(K) = CS*E(K) - SN*S(K)
               G = SN*S(K+1)
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL SROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL SROTG(F,G,CS,SN)
               S(K) = F
               F = CS*E(K) + SN*S(K+1)
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*E(K+1)
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     1            CALL SROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  560       CONTINUE
            E(M-1) = F
            ITER = ITER + 1
         GO TO 610
C
C        CONVERGENCE.
C
  570    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE.
C
            IF (S(L) .GE. 0.0E0) GO TO 580
               S(L) = -S(L)
               IF (WANTV) CALL SSCAL(P,-1.0E0,V(1,L),1)
  580       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  590       IF (L .EQ. MM) GO TO 600
               IF (S(L) .GE. S(L+1)) GO TO 600
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     1            CALL SSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     1            CALL SSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 590
  600       CONTINUE
            ITER = 0
            M = M - 1
  610    CONTINUE
      GO TO 360
  620 CONTINUE
      RETURN
      END


program convolve_or_deconvolve_field

! (de)convolve power spectrum using mode-coupling matrices
!   infp: input file of power spectrum
!   infn: input file of noise power spectrum (if "none", noise power set as 0)
!   outf: output file of (de)convolved power spectrum
!   infmsquare: input file of mode coupling matrix due to a square patch of sky
!   infminside: input file of mode coupling matrix due to a mask inside the square
!   ctype: if "d", deconvolve power, elseif "c", convolve power

  use fieldinfo_
  use sub_

  implicit none

  real, pointer :: cl(:),cln(:)
  double precision,dimension(npmax3,npmax3) :: mat,mat2
  character(100) :: infp,infn,infmsquare,infminside,outf
  character(1) :: ctype

  call getarg(1,infp)
  call getarg(2,infn)
  call getarg(3,outf)
  call getarg(4,infmsquare)
  call getarg(5,infminside)
  call getarg(6,ctype)

  call binninginit

  call readmat(infmsquare,mat)
  call readmat(infminside,mat2)

  allocate(cl(npmax3),cln(npmax3))
  call readcl3(infp,cl)
  call readcl3(infn,cln)
  cl=cl-cln
  if (ctype=="d") then
     call deconv_shear(cl,mat,mat2)
  elseif (ctype=="c") then
     call conv_shear(cl,mat,mat2)
  endif

  call outcl3(outf,cl)
  deallocate(cl,cln)

end program convolve_or_deconvolve_field


!-------------------------------------------------------------------------------
!
!+  vertical interpolation
!
!-------------------------------------------------------------------------------
module mod_vintrpl
  !-----------------------------------------------------------------------------
  !
  !++ Description:
  !       This module contains vertical interpolation subroutines.
  !
  !++ Current Corresponding Author : H.Tomita
  !
  !++ History:
  !      Version    Date      Comment
  !      -----------------------------------------------------------------------
  !      0.00       04-02-17  Imported from igdc-4.33
  !                 07-01-24  added VINTRPL_z_level2 (linear interpolation) and
  !                           consider undefined value (K.Suzuki)
  !      -----------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  !
  !++ Used modules
  !
  use mod_adm, only :   &
       ADM_gall,        &
       ADM_kall,        &
       ADM_lall,        &
       ADM_GALL_PL,     &
       ADM_LALL_PL,     &
       ADM_KNONE,       &
       ADM_kmin,        &
       ADM_kmax,        &
       ADM_prc_me,      &
       ADM_prc_pl
  use mod_grd, only :   &
       GRD_vz,GRD_vz_pl,&
       GRD_gz,          &
       GRD_ZH,GRD_Z,    &
       GRD_gzh
  use mod_cnst, only :  &
       CNST_UNDEF
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters, variables, and subroutines
  !
  public :: VINTRPL_srfc_val
  public :: VINTRPL_z_level
  public :: VINTRPL_z_level2
  public :: VINTRPL_zstar_level
  public :: VINTRPL_sigma_level
  public :: VINTRPL_mk_sigma
  public :: VINTRPL_half2full
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters, variables, and subroutines
  !
  ! < NONE >
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine VINTRPL_srfc_val( &
       var, var_pl,            & !--- IN    : 3d data
       svar, svar_pl,          & !--- OUT : surface data
       z_offset_in             & !--- IN  : z offset
       )
    !------
    !------ Caluculate surface value.( e.g. surface pressure )
    implicit none
    real(8), intent(in)  :: var(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(in)  :: var_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    real(8), intent(out) :: svar(ADM_gall,ADM_KNONE,ADM_lall)
    real(8), intent(out) :: svar_pl(ADM_GALL_PL,ADM_KNONE,ADM_LALL_PL)
    real(8), intent(in), optional  :: z_offset_in
    !
    real(8) :: lag_intpl
    real(8) :: z,z1,p1,z2,p2,z3,p3
    lag_intpl(z,z1,p1,z2,p2,z3,p3)             &
         = ((z-z2)*(z-z3))/((z1-z2)*(z1-z3))*p1&
         + ((z-z1)*(z-z3))/((z2-z1)*(z2-z3))*p2&
         + ((z-z1)*(z-z2))/((z3-z1)*(z3-z2))*p3
    !
    integer :: l,n
    real(8) :: z_offset
    !
    if(present(z_offset_in)) then
       z_offset = z_offset
    else
       z_offset = 0.0D0
    end if
    !
    do l=1,ADM_lall
       do n = 1, ADM_gall
          svar(n,ADM_KNONE,l) &
               = lag_intpl(GRD_vz(n,ADM_kmin,l,GRD_ZH)+z_offset,&
               GRD_vz(n,ADM_kmin+2,l,GRD_Z),var(n,ADM_kmin+2,l),&
               GRD_vz(n,ADM_kmin+1,l,GRD_Z),var(n,ADM_kmin+1,l),&
               GRD_vz(n,ADM_kmin  ,l,GRD_Z),var(n,ADM_kmin  ,l))
       end do
    end do
    if(ADM_prc_me==ADM_prc_pl) then
       do l=1,ADM_LALL_PL
          do n = 1, ADM_gall_pl
             svar_pl(n,ADM_KNONE,l) &
                  = lag_intpl(GRD_vz_pl(n,ADM_kmin,l,GRD_ZH)+z_offset,&
                  GRD_vz_pl(n,ADM_kmin+2,l,GRD_Z),var_pl(n,ADM_kmin+2,l),&
                  GRD_vz_pl(n,ADM_kmin+1,l,GRD_Z),var_pl(n,ADM_kmin+1,l),&
                  GRD_vz_pl(n,ADM_kmin  ,l,GRD_Z),var_pl(n,ADM_kmin  ,l))
          end do
       end do
    end if
  end subroutine VINTRPL_srfc_val
  !-----------------------------------------------------------------------------
  subroutine VINTRPL_z_level( v, v_pl, wgrid )
    implicit none
    real(8), intent(inout) :: v(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(inout) :: v_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    logical, intent(in) :: wgrid

    real(8) :: tmp(ADM_gall,ADM_kall,ADM_lall)
    real(8) :: tmp_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    integer :: l,k,n,kk

    integer :: kp
    real(8) :: lag_intpl_quadra, lag_intpl_linear
    real(8) :: z,z1,p1,z2,p2,z3,p3
    lag_intpl_quadra(z,z1,p1,z2,p2,z3,p3)       &
         = ((z-z2)*(z-z3))/((z1-z2)*(z1-z3))*p1 &
         + ((z-z1)*(z-z3))/((z2-z1)*(z2-z3))*p2 &
         + ((z-z1)*(z-z2))/((z3-z1)*(z3-z2))*p3
    lag_intpl_linear(z,z1,p1,z2,p2) &
         = (z-z2)/(z1-z2)*p1 &
         + (z1-z)/(z1-z2)*p2

    if(wgrid) then
       ! 07/01/24 K.Suzuki: consider undefined value
       do l=1,ADM_lall
       do k=ADM_kmin,ADM_kmax
       do n=1,ADM_gall
          if ( v(n,k+1,l) == CNST_UNDEF ) then
            tmp(n,k,l) = v(n,k,l)
          else if ( v(n,k,l) == CNST_UNDEF ) then
            tmp(n,k,l) = v(n,k+1,l)
          else
            tmp(n,k,l) = 0.5D0*(v(n,k+1,l)+v(n,k,l))
          end if
       end do
       end do
       end do
       tmp(:,ADM_kmin-1,:) = v(:,ADM_kmin,:)
       tmp(:,ADM_kmax+1,:) = v(:,ADM_kmax+1,:)

       If(ADM_prc_me==ADM_prc_pl) Then
          ! 07/01/24 K.Suzuki: consider undefined value
          do l=1,ADM_lall
          do k=ADM_kmin,ADM_kmax
          do n=1,ADM_gall
            if ( v_pl(n,k+1,l) == CNST_UNDEF ) then
              tmp_pl(n,k,l) = v_pl(n,k,l)
            else if ( v_pl(n,k,l) == CNST_UNDEF ) then
              tmp_pl(n,k,l) = v_pl(n,k+1,l)
            else
              tmp_pl(n,k,l) = 0.5D0*(v_pl(n,k+1,l)+v_pl(n,k,l))
            end if
          end do
          end do
          end do
          tmp_pl(:,ADM_kmin-1,:) = v_pl(:,ADM_kmin,:)
          tmp_pl(:,ADM_kmax+1,:) = v_pl(:,ADM_kmax+1,:)
       end If
    else
       tmp = v
       tmp_pl = v_pl
    end if

    Do l=1,ADM_lall
       do k=1,ADM_kall
          do n=1, ADM_gall
             if(      (GRD_gz(k)<GRD_vz(n,ADM_kmin,l,GRD_ZH))&
                  .or.(GRD_gz(k)>GRD_vz(n,ADM_kmax+1,l,GRD_ZH)) ) then
                v(n,k,l) = CNST_UNDEF
             else
                do kk = ADM_kmin-1,ADM_kmax+1
                   kp=kk
                   if(GRD_gz(k)<GRD_vz(n,kk,l,GRD_Z)) exit
                end do
!                if (kp==ADM_kmin-1) then
!                   kp=ADM_kmin
!                elseif(kp==ADM_kmax+1) then
!                   kp=ADM_kmax
!                end if
                if (kp<=ADM_kmin) then
                   kp=ADM_kmin+1
                elseif(kp>=ADM_kmax) then
                   kp=ADM_kmax-1
                end if
                ! 07/01/24 K.Suzuki: consider undefined value
                if ( tmp(n,kp+1,l) == CNST_UNDEF ) then
                  if ( tmp(n,kp,l) == CNST_UNDEF ) then
                    v(n,k,l) = tmp(n,kp-1,l)
                  else if ( tmp(n,kp-1,l) == CNST_UNDEF ) then
                    v(n,k,l) = tmp(n,kp,l)
                  else
                    v(n,k,l) &
                         = lag_intpl_linear(GRD_gz(k),         &
                         GRD_vz(n,kp  ,l,GRD_Z),tmp(n,kp  ,l), &
                         GRD_vz(n,kp-1,l,GRD_Z),tmp(n,kp-1,l)  )
                  end if
                else if ( tmp(n,kp,l) == CNST_UNDEF ) then
                   v(n,k,l) = tmp(n,kp-1,l)
                else if ( tmp(n,kp-1,l) == CNST_UNDEF ) then
                   v(n,k,l) = tmp(n,kp,l)
                else
                   v(n,k,l)                                    &
                        = lag_intpl_quadra(GRD_gz(k),          &
                        GRD_vz(n,kp+1,l,GRD_Z),tmp(n,kp+1,l),  &
                        GRD_vz(n,kp  ,l,GRD_Z),tmp(n,kp  ,l),  &
                        GRD_vz(n,kp-1,l,GRD_Z),tmp(n,kp-1,l) )
                end if
             end if
          end do
       end Do
    end Do
    If(ADM_prc_me==ADM_prc_pl) Then
       Do l=1,ADM_lall_pl
          do k=1,ADM_kall
             do n=1, ADM_gall_pl
                if(  (GRD_gz(k)<GRD_vz_pl(n,ADM_kmin,l,GRD_ZH)).or.&
                     (GRD_gz(k)>GRD_vz_pl(n,ADM_kmax+1,l,GRD_ZH)) ) then
                   v_pl(n,k,l) = CNST_UNDEF
                else
                   do kk = ADM_kmin-1,ADM_kmax+1
                     kp=kk
                     if(GRD_gz(k)<GRD_vz_pl(n,kk,l,GRD_Z)) exit
                   end do
!                   if(kp==ADM_kmin-1) then
!                      kp=ADM_kmin
!                   elseif(kp==ADM_kmax+1) then
!                      kp=ADM_kmax
!                   end if
                   if (kp<=ADM_kmin) then
                      kp=ADM_kmin+1
                   elseif(kp>=ADM_kmax) then
                      kp=ADM_kmax-1
                   end if
                   ! 07/01/24 K.Suzuki: consider undefined value
                   if ( tmp_pl(n,kp+1,l) == CNST_UNDEF ) then
                     if ( tmp_pl(n,kp,l) == CNST_UNDEF ) then
                       v_pl(n,k,l) = tmp_pl(n,kp-1,l)
                     else if ( tmp_pl(n,kp-1,l) == CNST_UNDEF ) then
                       v_pl(n,k,l) = tmp_pl(n,kp,l)
                     else
                       v_pl(n,k,l)                                  &
                              = lag_intpl_linear(GRD_gz(k),         &
                              GRD_vz_pl(n,kp  ,l,GRD_Z),tmp_pl(n,kp  ,l), &
                              GRD_vz_pl(n,kp-1,l,GRD_Z),tmp_pl(n,kp-1,l) )
                     end if
                   else if ( tmp_pl(n,kp,l) == CNST_UNDEF ) then
                      v_pl(n,k,l) = tmp_pl(n,kp-1,l)
                   else if ( tmp_pl(n,kp-1,l) == CNST_UNDEF ) then
                      v_pl(n,k,l) = tmp_pl(n,kp,l)
                   else
                      v_pl(n,k,l)                                       &
                           = lag_intpl_quadra(GRD_gz(k),                &
                           GRD_vz_pl(n,kp+1,l,GRD_Z),tmp_pl(n,kp+1,l),  &
                           GRD_vz_pl(n,kp  ,l,GRD_Z),tmp_pl(n,kp  ,l),  &
                           GRD_vz_pl(n,kp-1,l,GRD_Z),tmp_pl(n,kp-1,l) )
                   end if
                end if
             end do
          end Do
       end Do
    end If
  end subroutine VINTRPL_z_level
  !-----------------------------------------------------------------------------
  subroutine VINTRPL_z_level2( v, v_pl, wgrid ) ! 07/01/24 K.Suzuki [add]
    implicit none
    real(8), intent(inout) :: v(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(inout) :: v_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    logical, intent(in) :: wgrid

    real(8) :: tmp(ADM_gall,ADM_kall,ADM_lall)
    real(8) :: tmp_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    integer :: l,k,n,kk

    integer :: kp
    real(8) :: lag_intpl

    real(8) :: z,z1,p1,z2,p2
    lag_intpl(z,z1,p1,z2,p2)  &
         = (z-z2)/(z1-z2)*p1  &
         + (z1-z)/(z1-z2)*p2

    if(wgrid) then
       ! 07/01/24 K.Suzuki: consider undefined value
       do l=1, ADM_lall
       do k=ADM_kmin,ADM_kmax
       do n=1, ADM_gall
         if ( v(n,k+1,l) == CNST_UNDEF ) then
           tmp(n,k,l) = v(n,k,l)
         else if ( v(n,k,l) == CNST_UNDEF ) then
           tmp(n,k,l) = v(n,k+1,l)
         else
           tmp(n,k,l) = 0.5D0*(v(n,k+1,l)+v(n,k,l))
         end if
       end do
       end do
       end do
       tmp(:,ADM_kmin-1,:) = v(:,ADM_kmin,:)
       tmp(:,ADM_kmax+1,:) = v(:,ADM_kmax+1,:)

       If(ADM_prc_me==ADM_prc_pl) Then
          do l=1,ADM_lall
          do k=ADM_kmin,ADM_kmax
          do n=1,ADM_gall
            if ( v_pl(n,k+1,l) == CNST_UNDEF ) then
              tmp_pl(n,k,l) = v_pl(n,k,l)
            else if ( v_pl(n,k,l) == CNST_UNDEF ) then
              tmp_pl(n,k,l) = v_pl(n,k+1,l)
            else
              tmp_pl(n,k,l) = 0.5D0*(v_pl(n,k+1,l)+v_pl(n,k,l))
            end if
          end do
          end do
          end do
          tmp_pl(:,ADM_kmin-1,:) = v_pl(:,ADM_kmin,:)
          tmp_pl(:,ADM_kmax+1,:) = v_pl(:,ADM_kmax+1,:)
       end If
    else
       tmp = v
       tmp_pl = v_pl
    end if

    Do l=1,ADM_lall
       do k=1,ADM_kall
          do n=1, ADM_gall
             if(      (GRD_gz(k)<GRD_vz(n,ADM_kmin,l,GRD_ZH))&
                  .or.(GRD_gz(k)>GRD_vz(n,ADM_kmax+1,l,GRD_ZH)) ) then
                v(n,k,l) = CNST_UNDEF
             else
                do kk = ADM_kmin-1,ADM_kmax+1
                   kp=kk
                   if(GRD_gz(k)<GRD_vz(n,kk,l,GRD_Z)) exit
                end do
                if (kp<=ADM_kmin) then
                   v(n,k,l)=tmp(n,ADM_kmin,l)
                elseif(kp>=ADM_kmax+1) then
                   v(n,k,l)=tmp(n,ADM_kmax,l)
                else
                  ! 07/01/24 K.Suzuki: consider undefined value
                  if ( tmp(n,kp,l) == CNST_UNDEF ) then
                     v(n,k,l) = tmp(n,kp-1,l)
                  else if ( tmp(n,kp-1,l) == CNST_UNDEF ) then
                     v(n,k,l) = tmp(n,kp,l)
                  else
                     v(n,k,l)                                    &
                          = lag_intpl(GRD_gz(k),                 &
                          GRD_vz(n,kp  ,l,GRD_Z),tmp(n,kp  ,l),  &
                          GRD_vz(n,kp-1,l,GRD_Z),tmp(n,kp-1,l) )
                  end if
                end if
             end if
          end do
       end Do
    end Do
    If(ADM_prc_me==ADM_prc_pl) Then
       Do l=1,ADM_lall_pl
          do k=1,ADM_kall
             do n=1, ADM_gall_pl
                if(  (GRD_gz(k)<GRD_vz_pl(n,ADM_kmin,l,GRD_ZH)).or.&
                     (GRD_gz(k)>GRD_vz_pl(n,ADM_kmax+1,l,GRD_ZH)) ) then
                   v_pl(n,k,l) = CNST_UNDEF
                else
                   do kk = ADM_kmin-1,ADM_kmax+1
                     kp=kk
                     if(GRD_gz(k)<GRD_vz_pl(n,kk,l,GRD_Z)) exit
                   end do
                   if (kp<=ADM_kmin) then
                      v_pl(n,k,l) = tmp_pl(n,ADM_kmin,l)
                   else if(kp>=ADM_kmax+1) then
                      v_pl(n,k,l) = tmp_pl(n,ADM_kmax,l)
                   else
                     ! 07/01/24 K.Suzuki: consider undefined value
                     if ( tmp_pl(n,kp,l) == CNST_UNDEF ) then
                        v_pl(n,k,l) = tmp_pl(n,kp-1,l)
                     else if ( tmp_pl(n,kp-1,l) == CNST_UNDEF ) then
                        v_pl(n,k,l) = tmp_pl(n,kp,l)
                     else
                        v_pl(n,k,l)                                      &
                             = lag_intpl(GRD_gz(k),                      &
                             GRD_vz_pl(n,kp  ,l,GRD_Z),tmp_pl(n,kp  ,l), &
                             GRD_vz_pl(n,kp-1,l,GRD_Z),tmp_pl(n,kp-1,l) )
                     end if
                   end if
                end if
             end do
          end Do
       end Do
    end If
  end subroutine VINTRPL_z_level2
  !-----------------------------------------------------------------------------
  subroutine VINTRPL_zstar_level( v, v_pl, wgrid )
    implicit none
    real(8), intent(inout) :: v(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(inout) :: v_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    logical, intent(in) :: wgrid

    real(8) :: tmp(ADM_gall,ADM_kall,ADM_lall)
    real(8) :: tmp_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    !
    integer :: l,k,n,kk,kp
    real(8) :: lag_intpl
    real(8) :: z,z1,p1,z2,p2,z3,p3
    lag_intpl(z,z1,p1,z2,p2,z3,p3)             &
         = ((z-z2)*(z-z3))/((z1-z2)*(z1-z3))*p1&
         + ((z-z1)*(z-z3))/((z2-z1)*(z2-z3))*p2&
         + ((z-z1)*(z-z2))/((z3-z1)*(z3-z2))*p3
    if(wgrid) then
       tmp = v
       v(:,ADM_kmin-1,:) = CNST_UNDEF
       do l=1,ADM_lall
          do n = 1, ADM_gall
             do k = ADM_kmin, ADM_kmax+1
                do kk = 1, ADM_kall-1
                   if ( ( GRD_gzh(kk)   <= GRD_vz(n,k,l,GRD_ZH) ) .and. &
                        ( GRD_gzh(kk+1) >= GRD_vz(n,k,l,GRD_ZH) ) ) then
                      if(kk==1) then
                         kp=2
                      else
                         kp=kk
                      end if
                      v(n,k,l)                         &
                           = lag_intpl(GRD_vz(n,k,l,GRD_ZH),  &
                            GRD_gzh(kp+1),tmp(n,kp+1,l),&
                            GRD_gzh(kp  ),tmp(n,kp  ,l),&
                            GRD_gzh(kp-1),tmp(n,kp-1,l))
                      exit
                   end if
                end do
             end do
          end do
       end do
       If(ADM_prc_me==ADM_prc_pl) Then
          tmp_pl = v_pl
          v_pl(:,ADM_kmin-1,:) = CNST_UNDEF
          do l=1,ADM_lall_pl
             do n = 1, ADM_gall_pl
                do k = ADM_kmin, ADM_kmax+1
                   do kk = 1, ADM_kall-1
                      if ( ( GRD_gzh(kk)   <= GRD_vz_pl(n,k,l,GRD_ZH) ) .and. &
                           ( GRD_gzh(kk+1) >=  GRD_vz_pl(n,k,l,GRD_ZH) ) ) then
                         if(kk==1) then
                            kp=2
                         else
                            kp=kk
                         end if
                         v_pl(n,k,l)                     &
                           = lag_intpl(GRD_vz_pl(n,k,l,GRD_ZH), &
                           GRD_gzh(kp+1),tmp_pl(n,kp+1,l),&
                           GRD_gzh(kp  ),tmp_pl(n,kp  ,l),&
                           GRD_gzh(kp-1),tmp_pl(n,kp-1,l))
                         exit
                      end if
                   end do
                end do
             end do
          end do
       end If
    else !--- full grid
       tmp = v
       v(:,ADM_kmin-1,:) = CNST_UNDEF
       v(:,ADM_kmax+1,:) = CNST_UNDEF
       do l=1,ADM_lall
          do n = 1, ADM_gall
             do k = ADM_kmin, ADM_kmax
                do kk = 1, ADM_kall-1
                   if ( ( GRD_gz(kk)   <= GRD_vz(n,k,l,GRD_Z) ) .and. &
                        ( GRD_gz(kk+1) >=  GRD_vz(n,k,l,GRD_Z) ) ) then
                      if(kk==1) then
                         kp=2
                      else
                         kp=kk
                      end if
                      v(n,k,l)                              &
                           = lag_intpl(GRD_vz(n,k,l,GRD_Z), &
                            GRD_gz(kp+1),tmp(n,kp+1,l),     &
                            GRD_gz(kp  ),tmp(n,kp  ,l),     &
                            GRD_gz(kp-1),tmp(n,kp-1,l))
                      exit
                   end if
                end do
             end do
          end do
       end do
       If(ADM_prc_me==ADM_prc_pl) Then
          tmp_pl = v_pl
          v_pl(:,ADM_kmin-1,:) = CNST_UNDEF
          v_pl(:,ADM_kmax+1,:) = CNST_UNDEF
          do l=1,ADM_lall_pl
             do n = 1, ADM_gall_pl
                do k = ADM_kmin, ADM_kmax
                   do kk = 1, ADM_kall-1
                      if ( ( GRD_gz(kk)   <= GRD_vz_pl(n,k,l,GRD_Z) ) .and. &
                           ( GRD_gz(kk+1) >=  GRD_vz_pl(n,k,l,GRD_Z) ) ) then
                         if(kk==1) then
                            kp=2
                         else
                            kp=kk
                         end if
                         v_pl(n,k,l)                           &
                           = lag_intpl(GRD_vz_pl(n,k,l,GRD_Z), &
                           GRD_gz(kp+1),tmp_pl(n,kp+1,l),      &
                           GRD_gz(kp  ),tmp_pl(n,kp  ,l),      &
                           GRD_gz(kp-1),tmp_pl(n,kp-1,l))
                         exit
                      end if
                   end do
                end do
             end do
          end do
       end If
    end if
    !
  end subroutine VINTRPL_zstar_level
  !-----------------------------------------------------------------------------
  subroutine VINTRPL_half2full( v, v_pl )
    implicit none
    real(8), intent(inout) :: v(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(inout) :: v_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)

    real(8) :: tmp(ADM_gall,ADM_kall,ADM_lall)
    real(8) :: tmp_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    integer :: k

    do k=ADM_kmin,ADM_kmax
       tmp(:,k,:) = 0.5D0*(v(:,k+1,:)+v(:,k,:))
    end do
    tmp(:,ADM_kmin-1,:) = v(:,ADM_kmin,:)
    tmp(:,ADM_kmax+1,:) = v(:,ADM_kmax+1,:)
    v = tmp
    !
    If(ADM_prc_me==ADM_prc_pl) Then
       do k=ADM_kmin,ADM_kmax
          tmp_pl(:,k,:) = 0.5D0*(v_pl(:,k+1,:)+v_pl(:,k,:))
       end do
       tmp_pl(:,ADM_kmin-1,:) = v_pl(:,ADM_kmin,:)
       tmp_pl(:,ADM_kmax+1,:) = v_pl(:,ADM_kmax+1,:)
       v_pl = tmp_pl
    end If
    !
  end subroutine VINTRPL_half2full
  !-----------------------------------------------------------------------------
  subroutine VINTRPL_mk_sigma( sigma, sigma_pl, pre, pre_pl, pres, pres_pl )
    !
    implicit none
    !
    real(8), intent(out) :: sigma(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(out) :: sigma_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    real(8), intent(in) :: pre(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(in) :: pre_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    !
    real(8), intent(in) :: pres(ADM_gall,ADM_KNONE,ADM_lall)
    real(8), intent(in) :: pres_pl(ADM_GALL_PL,ADM_KNONE,ADM_LALL_PL)
    integer :: l,k,n
    !
    do l = 1, ADM_lall
       do k = 1,ADM_kall
          do n=1, ADM_gall
             sigma(n,k,l) = pre(n,k,l)/pres(n,ADM_KNONE,l)
          end do
       end do
    end do
    If(ADM_prc_me==ADM_prc_pl) Then
       do l = 1, ADM_lall_pl
          do k = 1,ADM_kall
             do n=1, ADM_gall_pl
                sigma_pl(n,k,l) = pre_pl(n,k,l)/pres_pl(n,ADM_KNONE,l)
             end do
          end do
       end do
    end If
    return
  end subroutine VINTRPL_mk_sigma
  !-----------------------------------------------------------------------------
  subroutine VINTRPL_sigma_level( &
       v, v_pl,                   &
       sigma, sigma_pl,           &
       sigma_lev, MAX_SIGMA,      &
       wgrid )
    implicit none
    real(8), intent(inout) :: v(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(inout) :: v_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    real(8), intent(in) :: sigma(ADM_gall,ADM_kall,ADM_lall)
    real(8), intent(in) :: sigma_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    integer, intent(in) :: MAX_SIGMA
    real(8), intent(in) :: sigma_lev(MAX_SIGMA)
    logical, intent(in) :: wgrid

    real(8) :: tmp(ADM_gall,ADM_kall,ADM_lall)
    real(8) :: tmp_pl(ADM_GALL_PL,ADM_kall,ADM_LALL_PL)
    real(8) :: a,b
    integer :: l,k,n,kk,kp

    if(wgrid) then
       do k=ADM_kmin,ADM_kmax
          tmp(:,k,:) = 0.5D0*(v(:,k+1,:)+v(:,k,:))
       end do
       tmp(:,ADM_kmin-1,:) = v(:,ADM_kmin,:)
       tmp(:,ADM_kmax+1,:) = v(:,ADM_kmax+1,:)

       If(ADM_prc_me==ADM_prc_pl) Then
          do k=ADM_kmin,ADM_kmax
             tmp_pl(:,k,:) = 0.5D0*(v_pl(:,k+1,:)+v_pl(:,k,:))
          end do
          tmp_pl(:,ADM_kmin-1,:) = v_pl(:,ADM_kmin,:)
          tmp_pl(:,ADM_kmax+1,:) = v_pl(:,ADM_kmax+1,:)
       end If
    else
       tmp = v
       tmp_pl = v_pl
    end if

    Do l=1,ADM_lall
       do k=1,MAX_SIGMA
          do n=1, ADM_gall
             do kk = ADM_kmin+1,ADM_kmax
               kp=kk
               if(sigma_lev(k)>sigma(n,kk,l)) exit
             end do
             a = sigma(n,kp,l)-sigma_lev(k)
             b = sigma_lev(k)-sigma(n,kp-1,l)
             v(n,k,l) = (b*tmp(n,kp,l) + a*tmp(n,kp-1,l))/(a+b)
          end do
       end Do
    end Do
    If(ADM_prc_me==ADM_prc_pl) Then
       Do l=1,ADM_lall_pl
          do k=1,MAX_SIGMA
             do n=1, ADM_gall_pl
                do kk = ADM_kmin+1,ADM_kmax
                  kp=kk
                   if(sigma_lev(k)>sigma_pl(n,kk,l)) exit
                end do
                a = sigma_pl(n,kp,l)-sigma_lev(k)
                b = sigma_lev(k)-sigma_pl(n,kp-1,l)
                v_pl(n,k,l) = (b*tmp_pl(n,kp,l) + a*tmp_pl(n,kp-1,l))/(a+b)
             end do
          end Do
       end Do
    end If
  end subroutine VINTRPL_sigma_level
  !-----------------------------------------------------------------------------
end module mod_vintrpl
!-------------------------------------------------------------------------------


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

module differentiation

    implicit none

    private

    public :: differentiate

    contains

    subroutine differentiate( dt, f, df, method )

        real, intent(in)                     :: dt
        real, dimension(:), intent(in)       :: f
        real, dimension(:), intent(out)      :: df
        integer, optional, intent(in)        :: method

    ! this subroutine differentiates a sampled function f given at
    ! equitistantly spaced points with the spacing dt and
    ! puts the result to df.

    ! the optional argument method is currently ignored.

    ! the differentiation is currently done by doing central differences:
    !        f'(t) = (f(t+dt)-f(t-dt)) / (2 dt)
    ! boundary points are done using forward or backward differences

        integer :: i,j,il,iu,jl,ju

        if (present(method)) return

        if (size(f) /= size(df)) then
            stop "sizes of input and output array for differentiation do not match."
        end if

        if (size(f) < 2) then
            stop "sizes of arrays for differentiation are too short."
        end if

        jl = lbound(df,1)
        ju = ubound(df,1)
        il = lbound(f,1)
        iu = ubound(f,1)

        j=jl+1
        do i=il+1,iu-1
            df(j) = ( f(i+1) - f(i-1) ) / (dt*2)
            j = j+1
        end do

        df(jl) = ( f(il+1)-f(il) ) / dt
        df(ju) = ( f(iu)-f(iu-1) ) / dt

    end subroutine differentiate

end module differentiation


program abdulmalik
	IMPLICIT NONE
    INTEGER::n
    logical::issorted,h
    REAL::w(20),k,SUM_P_V
    print*,"enter n"
    read*,n
    call READ_REAL_VECROR(w,n,20)
    K = SUM_P_V(w,n,20)
    h = issorted(w,n,20)
    print*,"k=",k,"h",h
END Program abdulmalik

SUBROUTINE READ_REAL_VECROR(w,n,s)
	IMPLICIT NONE
    INTEGER,INTENT(IN)::n,s
    REAL,INTENT(out)::w(s)
    INTEGER::i
    do i=1,n
      print*,"enter w(i)"
      read*,w(i)
    enddo
END SUBROUTINE READ_REAL_VECROR

REAL FUNCTION SUM_P_V(w,n,s)
	IMPLICIT NONE
    INTEGER,INTENT(IN)::n,s
    REAL,INTENT(in)::w(s)
    INTEGER::i
    REAL::sum=0
    do i=1,n
      sum=sum+w(i)
    enddo
    SUM_P_V=sum
end FUNCTION SUM_P_V

logical FUNCTION issorted(w,n,s)
	IMPLICIT NONE
    INTEGER,INTENT(IN)::n,s
    REAL,INTENT(in)::w(s)
    logical::x=.true.
    INTEGER::i
    do i=2,n
      if(w(i-1)<w(i))then
        x=.true.
      else
        x=.false.
        exit
      endif
    enddo
    issorted=x
end FUNCTION issorted


! test_enum_space.f90 --
!     Test program for enumerate_space module
!
program test_enum
    use enumerate_space

    implicit none

    integer :: i, index, x, y, z

    index = start_enumeration

    do i = 1,20
        call enum_quadrant( index, x, y )
        write(*,'(3i5)') index, x, y
    enddo

    x     = 60000
    index = (x / 2) * (x + 1) - 2 ! Watch out for overflows
    do i = 1,5
        call enum_quadrant( index, x, y )
        write(*,'(3i12)') index, x, y
    enddo

    index = start_enumeration
    do i = 1,10
        call enum_1dspace( index, x )
        write(*,'(3i12)') index, x
    enddo

    !
    ! Test the enumeration of the 3D octant
    !
    index = start_enumeration
    do i = 1,20
        call enum_octant( index, x, y, z )
        write(*,'(4i12)') index, x, y, z
    enddo

    !
    ! Test the enumeration of 2D space
    !
    index = start_enumeration
    do i = 1,20
        call enum_2dspace( index, x, y )
        write(*,'(4i12)') index, x, y
    enddo

!
! 2D space:
!
!                    +
!                    |
!              19   10   14
!                    |
!         17    8    3    5   12
!                    |
!   --+---11----4----1----2----7---16---
!                    |
!              13    6    9   18
!                    |
!                   15   20
!                    |
!                    +
!                    |
end program test_enum


program doconcurrentloop_02
implicit none

real, dimension(10) :: a
real :: sum
integer :: N, i

N = size(a)
sum = 0

do concurrent (i = 1:N)
    a(i) = a(i-1) + 5
end do

call arraySum(a, sum)

contains
    subroutine arraySum(a, sum)
        real, intent(in) :: a(:)
        real, intent(out) :: sum
        do concurrent (i = 1:N) reduce(+: s)
            sum = sum + a(i)
        end do
    end subroutine
end program


module myconst
  implicit none
  real(8), parameter :: pi = 3.141592653589793238
end module myconst


subroutine paramters_update
    use systemparams
    implicit none
    real :: ang,sind,cosd,delta,tand,spin_obliquity_rad
    real :: C_atm,f_l=0.9
    real :: mu, fi , ao, ac , part1 , part2 , part3 , part4
	real :: tt_1
	tt_1 = f_l*(p/p0)!-(1-f_l)*(p/p0)**4
    spin_obliquity_rad = spin_obliquity *(pi/180)
  !tau_0(:) = 0.79 +(0.15 - 0.79)*(sin(lat(:) - spin_obliquity_rad)**(2))
    boil = -0.055*p**6 + 1.2502*p**5 - 11.111*p**4 + 48.87*p**3-112.46*p**2+144.07*p+31.096 + 273
    phidot = 2.0*pi*(h_ang/(r*r))/year
    angular_position  = angular_position + phidot*dt
    if(angular_position>2.0*pi) then
         angular_position = mod(angular_position,2.0*pi)
    end if

    r = a*(1.0-e*e)/(1.0+e*cos(angular_position-phi_peri))
    insol(:) = (q0*star_lum)/(pi*r*r)
    sind = -sin(spin_obliquity)*cos(angular_position-phi_peri - azim_obliquity)
    delta = asin(sind)
    cosd = sqrt(1.0-sind*sind)
    tand = tan(delta)

    do i=1,nx+1
        cos_H(i) = -tan(lat(i))*tand
        if(abs(cos_H(i))>1.0) cos_H(i) = cos_H(i)/abs(cos_H(i))
        h = ACOS(cos_H(i))
        insol(i) = insol(i)*(H*sin(lat(i))*sind + cos(lat(i))*cosd*sin(H))
        f_ice(i) = 1.0 - exp(-(freeze-T(i))/10.0)

        if(f_ice(i)<0.0) then
            f_ice(i) =0.0
        end if

        C_atm = (p/p0)*C_atm0
        C_land = 1.0d9+C_atm
        C_ocean = 2.1d11+C_atm

        if(T(i)>=freeze) then
            C_ice = 0.0
        else if (T(i)<freeze.and. T(i)> freeze-10.0) then
            C_ice = 53.1d9
        else if(T(i)<=freeze-10.0) then
            C_ice = 11.1d9
        end if

        C_tot(i) = f_land*C_land + ocean_fraction*(f_ice(i)*C_ice + (1.0-f_ice(i))*C_ocean)

		if (H>0) then
			mu = sin(lat(i))*sind + (cos(lat(i))*cosd*sin(H))/H
		else if (H==0) then
			mu = 0.5
		end if
	    mu = 0.92*mu
        ao = (0.026/(1.1*mu**1.7+0.065))+0.15*(mu-0.1)*(mu-0.5)*(mu-1)
        fi = max(0.0,(1-exp((T(i)-273.0)/10.0)))
        ac = max(0.19,-0.07+8.d-3*ACOS(mu)*57.2957799513)
        part1 = (1-fi)*(ao*(0.33)+ac*0.67)
        part2 = fi*(0.62*(0.5)+ac*0.5)
        part3 = (1-fi)*(0.2*(0.5)+ac*0.5)
        part4 = fi*(0.85*(0.5)+ac*0.5)
        albedo(i) =(ocean_fraction)*(part1+part2)+(1-ocean_fraction)*(part3 + part4)
        tau_ir(i) = 0.9*(f_l*(p/p0)**(1.6)-(1-f_l)*(p/p0)**4)*(T(i)/freeze)**3
        infrared(i) = sigma_SB*(T(i)*T(i)*T(i)*T(i))/(1.0 + 0.79*tau_ir(i))
        Q(i) = insol(i)*(1.0-albedo(i)) - infrared(i)
        hab(i) = 0.0

        if (T(i)>=freeze.and.T(i)<=boil) then
            hab(i)=1.0
        end if

    end do

end subroutine paramters_update


      SUBROUTINE TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ,
     $                   TAU, TOL, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To find a controllable realization for the linear time-invariant
C     single-input system
C
C             dX/dt = A * X + B * U,
C                Y  = C * X,
C
C     where A is an N-by-N matrix, B is an N element vector, C is an
C     P-by-N matrix, and A and B are reduced by this routine to
C     orthogonal canonical form using (and optionally accumulating)
C     orthogonal similarity transformations, which are also applied
C     to C.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBZ    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix Z the orthogonal similarity transformations for
C             reducing the system, as follows:
C             = 'N':  Do not form Z and do not store the orthogonal
C                     transformations;
C             = 'F':  Do not form Z, but store the orthogonal
C                     transformations in the factored form;
C             = 'I':  Z is initialized to the unit matrix and the
C                     orthogonal transformation matrix Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation,
C             i.e. the order of the matrix A.  N >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs, or of rows of C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading NCONT-by-NCONT upper Hessenberg
C             part of this array contains the canonical form of the
C             state dynamics matrix, given by Z' * A * Z, of a
C             controllable realization for the original system. The
C             elements below the first subdiagonal are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, the original input/state vector B.
C             On exit, the leading NCONT elements of this array contain
C             canonical form of the input/state vector, given by Z' * B,
C             with all elements but B(1) set to zero.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output/state matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output/state matrix, given by C * Z, and
C             the leading P-by-NCONT part contains the output/state
C             matrix of the controllable realization.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     NCONT   (output) INTEGER
C             The order of the controllable state-space representation.
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If JOBZ = 'I', then the leading N-by-N part of this array
C             contains the matrix of accumulated orthogonal similarity
C             transformations which reduces the given system to
C             orthogonal canonical form.
C             If JOBZ = 'F', the elements below the diagonal, with the
C             array TAU, represent the orthogonal transformation matrix
C             as a product of elementary reflectors. The transformation
C             matrix can then be obtained by calling the LAPACK Library
C             routine DORGQR.
C             If JOBZ = 'N', the array Z is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDZ = 1 and
C             declare this array to be Z(1,1) in the calling program).
C
C     LDZ     INTEGER
C             The leading dimension of array Z. If JOBZ = 'I' or
C             JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.
C
C     TAU     (output) DOUBLE PRECISION array, dimension (N)
C             The elements of TAU contain the scalar factors of the
C             elementary reflectors used in the reduction of B and A.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in determining the
C             controllability of (A,B). If the user sets TOL > 0, then
C             the given value of TOL is used as an absolute tolerance;
C             elements with absolute value less than TOL are considered
C             neglijible. If the user sets TOL <= 0, then an implicitly
C             computed, default tolerance, defined by
C             TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead,
C             where EPS is the machine precision (see LAPACK Library
C             routine DLAMCH).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK. LDWORK >= MAX(1,N,P).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The Householder matrix which reduces all but the first element
C     of vector B to zero is found and this orthogonal similarity
C     transformation is applied to the matrix A. The resulting A is then
C     reduced to upper Hessenberg form by a sequence of Householder
C     transformations. Finally, the order of the controllable state-
C     space representation (NCONT) is determined by finding the position
C     of the first sub-diagonal element of A which is below an
C     appropriate zero threshold, either TOL or TOLDEF (see parameter
C     TOL); if NORM(B) is smaller than this threshold, NCONT is set to
C     zero, and no computations for reducing the system to orthogonal
C     canonical form are performed.
C     All orthogonal transformations determined in this process are also
C     applied to the matrix C, from the right.
C
C     REFERENCES
C
C     [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D.
C         Orthogonal Invariants and Canonical Forms for Linear
C         Controllable Systems.
C         Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981.
C
C     [2] Hammarling, S.J.
C         Notes on the use of orthogonal similarity transformations in
C         control.
C         NPL Report DITC 8/82, August 1982.
C
C     [3] Paige, C.C
C         Properties of numerical algorithms related to computing
C         controllability.
C         IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001,
C     Sept. 2003.
C
C     KEYWORDS
C
C     Controllability, minimal realization, orthogonal canonical form,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBZ
      INTEGER           INFO, LDA, LDC, LDWORK, LDZ, N, NCONT, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(*), C(LDC,*), DWORK(*), TAU(*),
     $                  Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           LJOBF, LJOBI, LJOBZ
      INTEGER           ITAU, J
      DOUBLE PRECISION  ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH,
     $                  TOLDEF, WRKOPT
C     .. Local Arrays ..
      DOUBLE PRECISION  NBLK(1)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR,
     $                  DORMHR, MB01PD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX
C     .. Executable Statements ..
C
      INFO = 0
      LJOBF = LSAME( JOBZ, 'F' )
      LJOBI = LSAME( JOBZ, 'I' )
      LJOBZ = LJOBF.OR.LJOBI
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -8
      ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDWORK.LT.MAX( 1, N, P ) ) THEN
         INFO = -15
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01ZD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      NCONT = 0
      DWORK(1) = ONE
      IF ( N.EQ.0 )
     $   RETURN
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      WRKOPT = ONE
C
C     Calculate the absolute norms of A and B (used for scaling).
C
      ANORM = DLANGE( 'Max', N, N, A, LDA, DWORK )
      BNORM = DLANGE( 'Max', N, 1, B, N, DWORK )
C
C     Return if matrix B is zero.
C
      IF( BNORM.EQ.ZERO ) THEN
         IF( LJOBF ) THEN
            CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ )
            CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N )
         ELSE IF( LJOBI ) THEN
            CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
         END IF
         RETURN
      END IF
C
C     Scale (if needed) the matrices A and B.
C
      CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO )
      CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO )
C
C     Calculate the Frobenius norm of A and the 1-norm of B (used for
C     controllability test).
C
      FANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK )
      FBNORM = DLANGE( '1-norm', N, 1, B, N, DWORK )
C
      TOLDEF = TOL
      IF ( TOLDEF.LE.ZERO ) THEN
C
C        Use the default tolerance in controllability determination.
C
         THRESH = DBLE(N)*DLAMCH( 'EPSILON' )
         TOLDEF = THRESH*MAX( FANORM, FBNORM )
      END IF
C
      ITAU = 1
      IF ( FBNORM.GT.TOLDEF ) THEN
C
C        B is not negligible compared with A.
C
         IF ( N.GT.1 ) THEN
C
C           Transform B by a Householder matrix Z1: store vector
C           describing this temporarily in B and in the local scalar H.
C
            CALL DLARFG( N, B(1), B(2), 1, H )
C
            B1 = B(1)
            B(1) = ONE
C
C           Form Z1 * A * Z1.
C           Workspace: need N.
C
            CALL DLARF( 'Right', N, N, B, 1, H, A, LDA, DWORK )
            CALL DLARF( 'Left',  N, N, B, 1, H, A, LDA, DWORK )
C
C           Form C * Z1.
C           Workspace: need P.
C
            CALL DLARF( 'Right', P, N, B, 1, H, C, LDC, DWORK )
C
            B(1) = B1
            TAU(1) = H
            ITAU = ITAU + 1
         ELSE
            B1 = B(1)
            TAU(1) = ZERO
         END IF
C
C        Reduce modified A to upper Hessenberg form by an orthogonal
C        similarity transformation with matrix Z2.
C        Workspace: need N;  prefer N*NB.
C
         CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO )
         WRKOPT = DWORK(1)
C
C        Form C * Z2.
C        Workspace: need P;  prefer P*NB.
C
         CALL DORMHR( 'Right', 'No transpose', P, N, 1, N, A, LDA,
     $                TAU(ITAU), C, LDC, DWORK, LDWORK, INFO )
         WRKOPT = MAX( WRKOPT, DWORK(1) )
C
         IF ( LJOBZ ) THEN
C
C           Save the orthogonal transformations used, so that they could
C           be accumulated by calling DORGQR routine.
C
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Full',  N-1, 1, B(2), N-1, Z(2,1), LDZ )
            IF ( N.GT.2 )
     $         CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, Z(3,2),
     $                      LDZ )
            IF ( LJOBI ) THEN
C
C              Form the orthogonal transformation matrix Z = Z1 * Z2.
C              Workspace: need N;  prefer N*NB.
C
               CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO )
               WRKOPT = MAX( WRKOPT, DWORK(1) )
            END IF
         END IF
C
C        Annihilate the lower part of A and B.
C
         IF ( N.GT.2 )
     $      CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA )
         IF ( N.GT.1 )
     $      CALL DLASET( 'Full',  N-1, 1, ZERO, ZERO, B(2), N-1 )
C
C        Find NCONT by checking sizes of the sub-diagonal elements of
C        transformed A.
C
         IF ( TOL.LE.ZERO )
     $      TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) )
C
         J = 1
C
C        WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO
C
   10    CONTINUE
         IF ( J.LT.N ) THEN
            IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN
               J = J + 1
               GO TO 10
            END IF
         END IF
C
C        END WHILE 10
C
C        First negligible sub-diagonal element found, if any: set NCONT.
C
         NCONT = J
         IF ( J.LT.N )
     $      A(J+1,J) = ZERO
C
C        Undo scaling of A and B.
C
         CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A,
     $                LDA, INFO )
         CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO )
         IF ( NCONT.LT.N )
     $      CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK,
     $                   A(1,NCONT+1), LDA, INFO )
      ELSE
C
C        B is negligible compared with A. No computations for reducing
C        the system to orthogonal canonical form have been performed,
C        except scaling (which is undoed).
C
         CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA,
     $                INFO )
         CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO )
         IF( LJOBF ) THEN
            CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ )
            CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N )
         ELSE IF( LJOBI ) THEN
            CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
         END IF
      END IF
C
C     Set optimal workspace dimension.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TB01ZD ***
      END