#include "dims.h"
      SUBROUTINE TSTADJ
      use init_module,only: tadjust,istep
      use cons_module,only: imax,imaxp2,kmax,expz,gask,p0
      implicit none
#include "params.h"
#include "fcom.h"
#include "vscr.h"
#include "index.h"
#include "buff.h"
#include "phys.h"
#include "lowbnd.h"
#include "grid.h"
!
! Local:
      integer :: i,k
      integer :: ncpk,nmsk,ntk
      real :: col1(zkmxp),col2(zkmxp),adjtemp(zkmxp)
C     ****
C     ****     GENERATE INPUTS FOR CONVECTIVE ADJUSTMENT
C     ****       S1 = PI
C     ****
      NCPK = NCP+1
      NMSK = NJ+NMS+1
C     ****
C     ****       S1(1) = P(1)**ALFA1
C     ****
      DO 1 I = 3,IMAXP2
        S1(I,1) = 1.
    1 CONTINUE
C     ****
C     ****       PI(K) = S1(K) = S1(K-1)*(P(K)/P(K-1))**ALFA(K-1)
C     ****
      DO 2 K = 2,KMAX
        NCPK = NCPK+1
        DO 2 I = 3,IMAXP2
          S1(I,K) = S1(I,K-1)*(expz(K)/expz(K-1))**(gask/(F(I,NCPK)*
     |      F(I,NMSK)))
    2 CONTINUE
!     call addfsech('TADJ_S1',' ',' ',s1,zimxp,kmaxp1,kmax,j)
C     ****
C     ****       S2 = Q
C     ****         S2(1) = PI(1)*DELTAP(1)
C     ****         S2(KMAX) = PI(KMAX)*DELTAP(KMAX-1)
C     ****
      DO 3 I = 3,IMAXP2
        S2(I,1) = S1(I,1)*p0*(expz(1)-expz(2))
        S2(I,KMAX) = S1(I,KMAX)*p0*(expz(KMAX-1)-expz(KMAX))
    3 CONTINUE
      DO 4 K = 2,KMAX-1
        DO 4 I = 3,IMAXP2
          S2(I,K) = S1(I,K)*p0*(expz(K-1)-expz(K+1))
    4 CONTINUE
!     call addfsech('TADJ_S2',' ',' ',s2,zimxp,kmaxp1,kmax,j)
C     ****
C     ****       S1 = BETA = 1/PI
C     ****       S3 = T
C     ****       S4 = THETA
C     ****
      NTK = NJNP+NT-1
      DO 5 K = 1,KMAX
        NTK = NTK +1
        DO 5 I = 1,IMAXP2
          S1(I,K) = 1./S1(I,K)
          S3(I,K) = F(I,NTK)
          S4(I,K) = S1(I,K)*S3(I,K)
    5 CONTINUE
C     ****
C     ****     IDENTIFY VALUES OF I FOR WHICH COLUMNS REQUIRE
C     ****       CONVECTIVE ADJUSTMENT.
C     ****
      DO 8 I = 3,IMAXP2
        T1(I) = 0.
    8 CONTINUE
      DO 9 K = 1,KMAX-1
        DO 9 I = 3,IMAXP2
          if (s4(i,k+1) < s4(i,k)) t1(i) = 1.
    9 CONTINUE
!     call addfsech('TADJ_S4',' ',' ',s4,zimxp,kmaxp1,kmax,j)
C     ****
C     ****     NOW PERFORM CONVECTIVE ADJUSTMENT WHERE NEEDED
C     ****
      NTK = NJNP+NT-1
      DO 10 I = 3,IMAXP2
        IF(T1(I).EQ.1.)THEN
          DO 11 K = 1,KMAX
            adjtemp(k) = s3(i,k)
            col2(k) = s2(i,k)
            col1(k) = s1(i,k)
   11     CONTINUE
!
! Update statistics on tn convective adjustment:
          tadjust(j)%nadj = tadjust(j)%nadj+1
!         write(6,"('tstadj istep=',i3,' j=',i3,' i=',i4,': increment ',
!    |      'tadjust(j)%nadj to',i4)") istep,j,i,tadjust(j)%nadj
          tadjust(j)%jiadj(tadjust(j)%nadj,1) = j
          tadjust(j)%jiadj(tadjust(j)%nadj,2) = i
          tadjust(j)%glocadj(tadjust(j)%nadj,1) = glat(j)
          tadjust(j)%glocadj(tadjust(j)%nadj,2) = glon(mod(i,nlon))
          tadjust(j)%tcol_preadj(tadjust(j)%nadj,:) = adjtemp(:)
!
! Adjtemp (temp) is intent(inout), col2 (q) and col1 (beta) are intent(in): 
!     SUBROUTINE ADJUST(TEMP,Q,BETA,KMAX)
!
          CALL ADJUST(adjtemp,col2,col1,kmax)
!
          tadjust(j)%tcol_postadj(tadjust(j)%nadj,:) = adjtemp(:)
C         ****
C         ****     PLACE NEW VALUES OF T IN F ARRAY
C         ****
          DO 12 K = 1,KMAX
            f(i,ntk+k) = adjtemp(k)
            if (adjtemp(k) < 100.) f(i,ntk+k) = 100.
   12     CONTINUE
        ENDIF
   10 CONTINUE
C     ****
C     ****     PERIODIC POINTS
C     ****
      NTK = NJNP+NT-1
      DO 13 I = 1,2
        DO 13 K=1,KMAX
          F(I,NTK+K) = F(I+IMAX,NTK+K)
          F(I+IMAXP2,NTK+K) = F(I+2,NTK+K)
   13 CONTINUE
      RETURN
      END