      SUBROUTINE CALSED
C
C CHANGE RECORD
C **  SUBROUTINE CALSED CALCULATES COHESIVE SEDIMENT SETTLING,
C **  DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
      USE GLOBAL
C
C**********************************************************************C
C
      IF(ISDYNSTP.EQ.0)THEN
        TIME=(DT*FLOAT(N)+TCON*TBEGIN)/TCON
      ELSE
        TIME=TIMESEC/TCON
      ENDIF

C
C**********************************************************************C
C
C **  COHESIVE SEDIMENT, KC=1 (SINGLE LAYER IN VERTICAL)
C
      IF(ISTRAN(6).GE.1.AND.KC.EQ.1)THEN
C PT -added SEDZLJ_main call.
C       ******************
      IF(NSEDFLUME.GT.0)THEN
         CALL SEDZLJ_MAIN
      ELSE
C       ******************
          DO NS=1,NSED
            DSEDGMM=1.0/(1.0E6*SSG(NS))
C
C----------------------------------------------------------------------C
C
C **  SET SETTLING VELOCITIES
C
          K=0
C
          IF(ISEDVW.EQ.0)THEN
            DO L=2,LA
              WSETA(L,K,NS)=WSEDO(NS)
            ENDDO
          ENDIF
C
          IF(ISEDVW.EQ.1)THEN
            DO L=2,LA
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),0.0,ISEDVW)
            ENDDO
          ENDIF
C
          IF(ISEDVW.EQ.2)THEN
	      IF(ISWAVE.EQ.0)THEN
              DO L=2,LA
                STRESS=QQ(L,0)/CTURB2
                SHEAR=2.*DZIC(K+1)*HPI(L)*SQRT(STRESS)/VKC
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),SHEAR,ISEDVW)
              ENDDO
	      ELSE
              DO L=2,LA
                TAUBC=QQ(L,0)/CTURB2
                UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
                VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
                CURANG=ATAN2(VTMP,UTMP)
                TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &              +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
                TAUB2=MAX(TAUB2,0.)
                STRESS=SQRT(TAUB2)
                SHEAR=2.*DZIC(K+1)*HPI(L)*SQRT(STRESS)/VKC
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),SHEAR,ISEDVW)
	        ENDDO
	      ENDIF
          ENDIF
C
          IF(ISEDVW.GE.3.AND.ISEDVW.LE.4)THEN
	      IF(ISWAVE.EQ.0)THEN
              DO L=2,LA
                STRESS=0.5*QQ(L,0)/CTURB2
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
              ENDDO
	      ELSE
              DO L=2,LA
                TAUBC=QQ(L,0)/CTURB2
                UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
                VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
                CURANG=ATAN2(VTMP,UTMP)
                TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &             +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
                TAUB2=MAX(TAUB2,0.)
                STRESS=0.5*SQRT(TAUB2)+0.5*QQ(L,1)/CTURB2
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
              ENDDO
	      ENDIF
          ENDIF
C
          IF(ISEDVW.EQ.5)THEN
            DO L=2,LA
              UUSTARTMP=QCELLCTR(L)*SQRT(QQ(L,0)/CTURB2)
              STRESS=SQRT(HPI(L)*HPI(L)*UUSTARTMP)
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
            ENDDO
          ENDIF
C
          IF(ISEDVW.GE.1)THEN
            DO L=2,LA
              WSETA(L,K,NS)=MAX(WSETA(L,K,NS),WSEDO(NS))
            ENDDO
          ENDIF
C
C----------------------------------------------------------------------C
C
C **  HORIZONTAL LOOP
C
          DO L=2,LA
            SEDF(L,1,NS)=0.0
            PROBDEP=0.0
            WESE=0.0
C **  SET MAXIMUM EROSION RATE
c1104            WESEMX=0.5*DELTI*CTMPDRY(L)*SEDB(L,KBT(L),NS)
            WESEMX=DELTI*CTMPDRY(L)*SEDB(L,KBT(L),NS)
c1104            IF(KBT(L).NE.1) WESEMX=3.*WESEMX
            WESEMX=MAX(WESEMX,0.)
            IF(TAUBSED(L).GT.TAURB(L,KBT(L)))THEN
C **  MASS EROSION
              WESE=CTMPDRY(L)*WRSPB(L,KBT(L))*VFRBED(L,KBT(L),NS)
              WESE=MIN(WESE,WESEMX)
            ELSE
              IF(TAUBSED(L).GT.TAURS(L,KBT(L)))THEN
C **  SURFACE EROSION
                WESE=CTMPDRY(L)*WRSPS(L,KBT(L))*VFRBED(L,KBT(L),NS)
c1104                WESE=MIN(WESE,WESEMX)
                TAURTMP=TAURS(L,KBT(L))
C#######################################################################
C     HQI Change, 01/05/04, SO and RM
C     Change to implement HQI Sed-flume analysis based critical shear
C     stress options
C                IF(IWRSP(1).GE.2) TAURTMP=TAUR(1)
                IF((IWRSP(1).GE.2).AND.(IWRSP(1).LT.99)) TAURTMP=TAUR(1)
C#######################################################################
                TAUE=(TAUBSED(L)-TAURS(L,KBT(L)))/TAURTMP
                TAUE=MAX(TAUE,0.0)
	          TMPSEDHID=1.0
	          IF(ISTRAN(7).GE.1.AND.COSEDHID(1).NE.0.0)
     &            TMPSEDHID=(FRACCOH(L,KBT(L)))**COSEDHID(1)
C#######################################################################
C     HQI change to implement spatially varying coefficient and exponent
C     in resuspension formulation based on Ed G analysis of Sed-flume data
C
                IF(IWRSP(1).LT.99)THEN
                      WESE=TMPSEDHID*WESE*(TAUE**TEXP(NS))
                ELSE
                  ! SO   HQI change to implement spatially varying coefficient and exponent
                  ! SO   in resuspension formulation based re-analysis of Sedflume data with
                  ! SO   a new partition of domain (see SSEDTOX.FOR, line 587)
                  ! SO   05/14/04
                  IF ( L.LE.2042 ) THEN
                    WESE=TMPSEDHID*WESE*(TAUE**0.949) ! All of 5C
                  ELSE                                !      + Woods Pond
                    WESE=TMPSEDHID*WESE*(TAUE**1.59 ) ! North of (All of
                  END IF                              !   5C + Woods Pond)

                ENDIF
C#######################################################################
c1104
                WESE=MIN(WESE,WESEMX)
c1104
              ELSE
C **  NO EROSION
                WESE=0.0
              ENDIF
            ENDIF
C **  SET PROBABILITY OF DEPOSITION
C#######################################################################
C     HQI Change, 04/25/04
C     Change to compute probability of deposition using total bed shear
C     rather than cohesive grain shear
c            IF(TAUBSED(L).LT.TAUD(NS))
c     &        PROBDEP=(TAUD(NS)-TAUBSED(L))/TAUD(NS)
            IF(TAUB(L).LT.TAUD(NS))
     &           PROBDEP=(TAUD(NS)-TAUB(L))/TAUD(NS)
C#######################################################################
            IF(SED(L,1,NS).GT.SEDMDGM) PROBDEP=1.
            WSETMP=PROBDEP*WSETA(L,0,NS)
            WVEL=DELT*HPI(L)*DZIC(1)
            CLEFT=1.+WSETMP*WVEL
            CRIGHT=MAX(SED(L,1,NS),0.)+(WESE-SEDF(L,1,NS))*WVEL
            SED(L,1,NS)=CRIGHT/CLEFT
            SEDF(L,0,NS)=-WSETMP*SED(L,1,NS)+WESE
            SEDBTMP=SEDB(L,KBT(L),NS)-DELT*SEDF(L,0,NS)
            ! *** Limit Erosion to Available Mass
            IF(SEDBTMP.LT.0.0)THEN
              SEDF(L,0,NS)=DELTI*SEDB(L,KBT(L),NS)
              SEDBTMP=0.0
              SED(L,1,NS)=SEDS(L,1,NS)+(SEDF(L,0,NS)-SEDF(L,1,NS))*WVEL
            ENDIF
            SEDB1(L,KBT(L),NS)=SEDB(L,KBT(L),NS)
            SEDB(L,KBT(L),NS)=SEDBTMP
            QSBDTOP(L)=QSBDTOP(L)+DSEDGMM*SEDF(L,0,NS)
            QWBDTOP(L)=QWBDTOP(L)+DSEDGMM*
     &                 ( VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.)
     &                  +VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.) )
          ENDDO
C
C----------------------------------------------------------------------C
C
        ENDDO
       ENDIF
      ENDIF

C
C**********************************************************************C
C
C **  COHESIVE SEDIMENT, KC=2 (TWO LAYERS IN VERTICAL)
C
      IF(ISTRAN(6).GE.1.AND.KC.EQ.2)THEN
C       ******************
      IF(NSEDFLUME.GT.0)THEN
         CALL SEDZLJ_MAIN
      ELSE
C       ******************
        DO NS=1,NSED
          DSEDGMM=1./(1.E6*SSG(NS))
C
C----------------------------------------------------------------------C
C
C **  SET SETTLING VELOCITIES
C
          IF(ISEDVW.EQ.0)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=WSEDO(NS)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISEDVW.EQ.1)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),0.0,ISEDVW)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISEDVW.EQ.2)THEN
            K=0
            DO L=2,LA
              TAUBC=QQ(L,0)/CTURB2
              UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
              VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
              CURANG=ATAN2(VTMP,UTMP)
              TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &              +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
              TAUB2=MAX(TAUB2,0.)
              STRESS=SQRT(TAUB2)
              SHEAR=2.*DZIC(K+1)*HPI(L)*SQRT(STRESS)/VKC
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),SHEAR,ISEDVW)
            ENDDO
            K=1
            DO L=2,LA
              LN=LNC(L)
              SHEAR=HPI(L)*SQRT( DZIGSD4(K) )
     &              *SQRT( (U(LEAST(L),K+1)-U(LEAST(L),K)+U(L,K+1)-U(L,K))**2
     &                    +(V(LN ,K+1)-V(LN ,K)+V(L,K+1)-V(L,K))**2 )
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),SHEAR,ISEDVW)
            ENDDO
          ENDIF
C
          IF(ISEDVW.GE.3)THEN
            K=0
            DO L=2,LA
              TAUBC=QQ(L,0)/CTURB2
              UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
              VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
              CURANG=ATAN2(VTMP,UTMP)
              TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &            +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
              TAUB2=MAX(TAUB2,0.)
              STRESS=SQRT(TAUB2)
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
            ENDDO
            K=1
            DO L=2,LA
              LN=LNC(L)
              STRESS=AV(L,K)*SQRT( DZIGSD4(K) )
     &              *SQRT( (U(LEAST(L),K+1)-U(LEAST(L),K)+U(L,K+1)-U(L,K))**2
     &                    +(V(LN ,K+1)-V(LN ,K)+V(L,K+1)-V(L,K))**2 )
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
            ENDDO
          ENDIF
C
C----------------------------------------------------------------------C
C
C **  HORIZONTAL LOOPS
C
          K=2
          DO L=2,LA
            SEDF(L,K,NS)=0.
            WVEL=DELT*HPI(L)*DZIC(K)
            CLEFT=1.+WSETA(L,K-1,NS)*WVEL
            CRIGHT=MAX(SED(L,K,NS),0.)
            SED(L,K,NS)=CRIGHT/CLEFT
            SEDF(L,K-1,NS)=-WSETA(L,K-1,NS)*SED(L,K,NS)
          ENDDO
C
          DO L=2,LA
            PROBDEP=0.
            WESE=0.
C **  SET MAXIMUM EROSION RATE
c1104            WESEMX=0.5*DELTI*CTMPDRY(L)*SEDB(L,KBT(L),NS)
            WESEMX=DELTI*CTMPDRY(L)*SEDB(L,KBT(L),NS)
c1104            IF(KBT(L).NE.1) WESEMX=3.*WESEMX
            WESEMX=MAX(WESEMX,0.)
            IF(TAUBSED(L).GT.TAURB(L,KBT(L)))THEN
C **  MASS EROSION
              WESE=CTMPDRY(L)*WRSPB(L,KBT(L))*VFRBED(L,KBT(L),NS)
              WESE=MIN(WESE,WESEMX)
            ELSE
              IF(TAUBSED(L).GT.TAURS(L,KBT(L)))THEN
C **  SURFACE EROSION
                WESE=CTMPDRY(L)*WRSPS(L,KBT(L))*VFRBED(L,KBT(L),NS)
c1104                WESE=MIN(WESE,WESEMX)
                TAURTMP=TAURS(L,KBT(L))
	          IF(IWRSP(1).GE.2)TAURTMP=TAUR(1)
                TAUE=(TAUBSED(L)-TAURS(L,KBT(L)))/TAURTMP
                TAUE=MAX(TAUE,0.0)
                TMPSEDHID=1.0
	          IF(ISTRAN(7).GE.1.AND.COSEDHID(1).NE.0.0)
     &            TMPSEDHID=(FRACCOH(L,KBT(L)))**COSEDHID(1)
                WESE=TMPSEDHID*WESE*(TAUE**TEXP(NS))
c1104
                WESE=MIN(WESE,WESEMX)
c1104
              ELSE
C **  NO EROSION
                WESE=0.0
              ENDIF
            ENDIF
C **  SET PROBABILITY OF DEPOSITION
            IF(TAUBSED(L).LT.TAUD(NS))
     &         PROBDEP=(TAUD(NS)-TAUBSED(L))/TAUD(NS)
            IF(SED(L,1,NS).GT.SEDMDGM) PROBDEP=1.
            WSETMP=PROBDEP*WSETA(L,0,NS)
            WVEL=DELT*HPI(L)*DZIC(1)
            CLEFT=1.+WSETMP*WVEL
            CRIGHT=MAX(SED(L,1,NS),0.)+(WESE-SEDF(L,1,NS))*WVEL
            SED(L,1,NS)=CRIGHT/CLEFT
            SEDF(L,0,NS)=-WSETMP*SED(L,1,NS)+WESE
cjmh216            SEDBTMP=SEDB1(L,KBT(L),NS)-DELT*SEDF(L,0,NS)
            SEDBTMP=SEDB(L,KBT(L),NS)-DELT*SEDF(L,0,NS)
C           IF(SEDBTMP.LT.0.0)THEN
C             SEDF(L,0,NS)=0.
C             SEDBTMP=SEDB1(L,KBT(L),NS)
C             SED(L,1,NS)=SEDS(L,1,NS)-SEDF(L,1,NS)*WVEL
C           ENDIF
C           SEDB1(L,KBT(L),NS)=S3TL*SEDB(L,KBT(L),NS)
C     &                        +S2TL*SEDB1(L,KBT(L),NS)
C           SEDB(L,KBT(L),NS)=SEDBTMP
            IF(SEDBTMP.LT.0.0)THEN
c1104              SEDF(L,0,NS)=DELTI*SEDB1(L,KBT(L),NS)
c1104
              SEDF(L,0,NS)=DELTI*SEDB(L,KBT(L),NS)
c1104
              SEDBTMP=0.0
              SED(L,1,NS)=SEDS(L,1,NS)
     &                       +(SEDF(L,0,NS)-SEDF(L,1,NS))*WVEL
            ENDIF
cjmh216            SEDB1(L,KBT(L),NS)=S3TL*SEDB(L,KBT(L),NS)
cjmh216     &                        +S2TL*SEDB1(L,KBT(L),NS)
            SEDB1(L,KBT(L),NS)=SEDB(L,KBT(L),NS)
            SEDB(L,KBT(L),NS)=SEDBTMP
            QSBDTOP(L)=QSBDTOP(L)+DSEDGMM*SEDF(L,0,NS)
            QWBDTOP(L)=QWBDTOP(L)+DSEDGMM*
     &                 ( VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.)
     &                  +VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.) )
          ENDDO
C
C----------------------------------------------------------------------C
C
C **  ANTI-DIFFUSION OF COHESIVE SEDIMENT  KC.EQ.2
C
          IF(ISTOPT(6).EQ.1)THEN
C
            DO L=2,LA
              CRNUM=1.+DELT*WSETA(L,1,NS)*HPI(L)*DZIC(KC)
              GRADSED=(SED(L,KC,NS)-SED(L,1,NS))/(DZC(KC)+DZC(1))
              SEDAVG=0.5*(SED(L,KC,NS)+SED(L,1,NS)+1.E-16)
              WSETA(L,1,NS)=-CRNUM*DZC(KC)*WSETA(L,1,NS)*GRADSED/SEDAVG
            ENDDO
C
            DO L=2,LA
              AA11=DELTI*DZC(1)*HP(L)-MIN(WSETA(L,1,NS),0.)
              AA12=-MAX(WSETA(L,1,NS),0.)
              AA21=MIN(WSETA(L,1,NS),0.)
              AA22=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,1,NS),0.)
              BB11=DELTI*DZC(1)*HP(L)*SED(L,1,NS)
              BB22=DELTI*DZC(KC)*HP(L)*SED(L,KC,NS)
              DETI=1./(AA11*AA22-AA12*AA21)
              SED(L,1,NS)=DETI*( BB11*AA22-BB22*AA12 )
              SED(L,KC,NS)=DETI*( AA11*BB22-AA21*BB11 )
            ENDDO
C
          ENDIF
C
C----------------------------------------------------------------------C
C
C **  FINAL FLUX KC=2
C
          DO L=2,LA
            SEDF(L,1,NS)=DELTI*DZC(KC)*HP(L)*(SED(L,KC,NS)
     &     -SEDS(L,KC,NS))
          ENDDO
C
C----------------------------------------------------------------------C
C
        ENDDO
      ENDIF
      ENDIF
C
C PT note: end of KC = 2 loop.  added another ENDIF to accomodate for the call SEDZLJ IF loop.
C**********************************************************************C
C
C **  COHESIVE SEDIMENT, KC=3 (THREE LAYERS IN VERTICAL)
C
      IF(ISTRAN(6).GE.1.AND.KC.EQ.3)THEN
C      ********************************
C PT--add call to SEDZLJ.
      IF(NSEDFLUME.GT.0)THEN
         CALL SEDZLJ_MAIN
      ELSE
C       ******************
        DO NS=1,NSED
          DSEDGMM=1./(1.E6*SSG(NS))
C
C----------------------------------------------------------------------C
C
C **  SET SETTLING VELOCITIES
C
          IF(ISEDVW.EQ.0)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=WSEDO(NS)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISEDVW.EQ.1)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),0.0,ISEDVW)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISEDVW.EQ.2)THEN
            K=0
            DO L=2,LA
              TAUBC=QQ(L,0)/CTURB2
              UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
              VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
              CURANG=ATAN2(VTMP,UTMP)
              TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &              +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
              TAUB2=MAX(TAUB2,0.)
              STRESS=SQRT(TAUB2)
              SHEAR=2.*DZIC(K+1)*HPI(L)*SQRT(STRESS)/VKC
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),SHEAR,ISEDVW)
            ENDDO
            DO K=1,KS
              DO L=2,LA
                LN=LNC(L)
                SHEAR=HPI(L)*SQRT( DZIGSD4(K) )
     &              *SQRT( (U(LEAST(L),K+1)-U(LEAST(L),K)+U(L,K+1)-U(L,K))**2
     &                    +(V(LN ,K+1)-V(LN ,K)+V(L,K+1)-V(L,K))**2 )
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),SHEAR,ISEDVW)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISEDVW.GE.3)THEN
            K=0
            DO L=2,LA
              TAUBC=QQ(L,0)/CTURB2
              UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
              VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
              CURANG=ATAN2(VTMP,UTMP)
              TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &              +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
              TAUB2=MAX(TAUB2,0.)
              STRESS=SQRT(TAUB2)
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
            ENDDO
            DO K=1,KS
              DO L=2,LA
                LN=LNC(L)
                STRESS=AV(L,K)*SQRT( DZIGSD4(K) )
     &              *SQRT( (U(LEAST(L),K+1)-U(LEAST(L),K)+U(L,K+1)-U(L,K))**2
     &                    +(V(LN ,K+1)-V(LN ,K)+V(L,K+1)-V(L,K))**2 )
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
              ENDDO
            ENDDO
          ENDIF
C
C----------------------------------------------------------------------C
C
C **  HORIZONTAL LOOPS
C
          K=3
          DO L=2,LA
            SEDF(L,K,NS)=0.
            WVEL=DELT*HPI(L)*DZIC(K)
            CLEFT=1.+WSETA(L,K-1,NS)*WVEL
            CRIGHT=MAX(SED(L,K,NS),0.)
            SED(L,K,NS)=CRIGHT/CLEFT
            SEDF(L,K-1,NS)=-WSETA(L,K-1,NS)*SED(L,K,NS)
          ENDDO
C
          K=2
          DO L=2,LA
            WVEL=DELT*HPI(L)*DZIC(K)
            CLEFT=1.+WSETA(L,K-1,NS)*WVEL
            CRIGHT=MAX(SED(L,K,NS),0.)-SEDF(L,K,NS)*WVEL
            SED(L,K,NS)=CRIGHT/CLEFT
            SEDF(L,K-1,NS)=-WSETA(L,K-1,NS)*SED(L,K,NS)
          ENDDO
C
          DO L=2,LA
            PROBDEP=0.
            WESE=0.
C **  SET MAXIMUM EROSION RATE
c1104            WESEMX=0.5*DELTI*CTMPDRY(L)*SEDB(L,KBT(L),NS)
            WESEMX=DELTI*CTMPDRY(L)*SEDB(L,KBT(L),NS)
c1104            IF(KBT(L).NE.1) WESEMX=3.*WESEMX
            IF(TAUBSED(L).GT.TAURB(L,KBT(L)))THEN
C **  MASS EROSION
               WESE=CTMPDRY(L)*WRSPB(L,KBT(L))*VFRBED(L,KBT(L),NS)
               WESE=MIN(WESE,WESEMX)
            ELSE
              IF(TAUBSED(L).GT.TAURS(L,KBT(L)))THEN
C **  SURFACE EROSION
                WESE=CTMPDRY(L)*WRSPS(L,KBT(L))*VFRBED(L,KBT(L),NS)
c1104                WESE=MIN(WESE,WESEMX)
                TAURTMP=TAURS(L,KBT(L))
	          IF(IWRSP(1).GE.2)TAURTMP=TAUR(1)
                TAUE=(TAUBSED(L)-TAURS(L,KBT(L)))/TAURTMP
                TAUE=MAX(TAUE,0.0)
                TMPSEDHID=1.0
	          IF(ISTRAN(7).GE.1.AND.COSEDHID(1).NE.0.0)
     &            TMPSEDHID=(FRACCOH(L,KBT(L)))**COSEDHID(1)
                WESE=TMPSEDHID*WESE*(TAUE**TEXP(NS))
c1104
                WESE=MIN(WESE,WESEMX)
c1104
              ELSE
C **  NO EROSION
                WESE=0.0
              ENDIF
            ENDIF
C **  SET PROBABILITY OF DEPOSITION
            IF(TAUBSED(L).LT.TAUD(NS))
     &         PROBDEP=(TAUD(NS)-TAUBSED(L))/TAUD(NS)
            IF(SED(L,1,NS).GT.SEDMDGM) PROBDEP=1.
            WSETMP=PROBDEP*WSETA(L,0,NS)
            WVEL=DELT*HPI(L)*DZIC(1)
            CLEFT=1.+WSETMP*WVEL
            CRIGHT=MAX(SED(L,1,NS),0.)+(WESE-SEDF(L,1,NS))*WVEL
            SED(L,1,NS)=CRIGHT/CLEFT
            SEDF(L,0,NS)=-WSETMP*SED(L,1,NS)+WESE
cjmh216            SEDBTMP=SEDB1(L,KBT(L),NS)-DELT*SEDF(L,0,NS)
            SEDBTMP=SEDB(L,KBT(L),NS)-DELT*SEDF(L,0,NS)
C           IF(SEDBTMP.LT.0.0)THEN
C             SEDF(L,0,NS)=0.
C             SEDBTMP=SEDB1(L,KBT(L),NS)
C             SED(L,1,NS)=SEDS(L,1,NS)-SEDF(L,1,NS)*WVEL
C           ENDIF
C           SEDB1(L,KBT(L),NS)=S3TL*SEDB(L,KBT(L),NS)
C     &                        +S2TL*SEDB1(L,KBT(L),NS)
C           SEDB(L,KBT(L),NS)=SEDBTMP
            IF(SEDBTMP.LT.0.0)THEN
c1104              SEDF(L,0,NS)=DELTI*SEDB1(L,KBT(L),NS)
c1104
              SEDF(L,0,NS)=DELTI*SEDB(L,KBT(L),NS)
c1104
              SEDBTMP=0.0
              SED(L,1,NS)=SEDS(L,1,NS)
     &                       +(SEDF(L,0,NS)-SEDF(L,1,NS))*WVEL
            ENDIF
cjmh216            SEDB1(L,KBT(L),NS)=S3TL*SEDB(L,KBT(L),NS)
cjmh216     &                        +S2TL*SEDB1(L,KBT(L),NS)
            SEDB1(L,KBT(L),NS)=SEDB(L,KBT(L),NS)
            SEDB(L,KBT(L),NS)=SEDBTMP
            QSBDTOP(L)=QSBDTOP(L)+DSEDGMM*SEDF(L,0,NS)
            QWBDTOP(L)=QWBDTOP(L)+DSEDGMM*
     &                 ( VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.)
     &                  +VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.) )
          ENDDO
C
C----------------------------------------------------------------------C
C
C **  ANTI-DIFFUSION OF COHESIVE SEDIMENT  KC.EQ.3
C
          IF(ISTOPT(6).EQ.1)THEN
C
            DO K=1,2
              DO L=2,LA
                CRNUM=1.+DELT*WSETA(L,K,NS)*HPI(L)*DZIC(K+1)
                GRADSED=(SED(L,K+1,NS)-SED(L,K,NS))/(DZC(K+1)+DZC(K))
                SEDAVG=0.5*(SED(L,K+1,NS)-SED(L,K,NS)+1.E-16)
                WSETA(L,K,NS)=-CRNUM*DZC(K+1)*WSETA(L,K,NS)*
     &                         GRADSED/SEDAVG
              ENDDO
            ENDDO
C
C     TVAR1S=LOWER DIAGONAL
            DO L=2,LA
              TVAR1S(L,1)=0
            ENDDO
            DO K=2,KC
              DO L=2,LA
                TVAR1S(L,K)=MIN(WSETA(L,K-1,NS),0.)
              ENDDO
            ENDDO
C     TVAR1N=UPPER DIAGONAL
            DO L=2,LA
              TVAR1N(L,KC)=0
            ENDDO
            DO K=1,KS
              DO L=2,LA
                TVAR1N(L,K)=-MAX(WSETA(L,K,NS),0.)
              ENDDO
            ENDDO
C     TVAR1W=MAIN DIAGONAL
            DO L=2,LA
              TVAR1W(L,1)=DELTI*DZC(1)*HP(L)-MIN(WSETA(L,1,NS),0.)
              TVAR1W(L,KC)=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,KC-1,NS),0.)
            ENDDO
            DO K=2,KS
              DO L=2,LA
                TVAR1W(L,K)=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,K-1,NS),0.)
     &                -MIN(WSETA(L,K,NS),0.)
              ENDDO
            ENDDO
C     TVAR1E=RIGHT HAND SIDE
            DO K=1,KC
              DO L=2,LA
                TVAR1E(L,K)=DELTI*DZC(KC)*HP(L)*SED(L,K,NS)
              ENDDO
            ENDDO
C
C     TVAR3S=BET,TVAR2N=U,TVAR2S=GAM ARE WORKING ARRAYS
            DO L=2,LA
              TVAR3S(L)=TVAR1W(L,1)
            ENDDO
            DO L=2,LA
              TVAR2N(L,1)=TVAR1E(L,1)/TVAR3S(L)
            ENDDO
            DO K=2,KC
              DO L=2,LA
                TVAR2S(L,K)=TVAR1N(L,K-1)/TVAR3S(L)
                TVAR3S(L)=TVAR1W(L,K)-TVAR1S(L,K)*TVAR2S(L,K)
                TVAR2N(L,K)=(TVAR1E(L,K)-TVAR1S(L,K)*TVAR2N(L,K-1))/
     &                      TVAR3S(L)
              ENDDO
            ENDDO
            DO K=KS,1,-1
              DO L=2,LA
                TVAR2N(L,K)=TVAR2N(L,K)-TVAR2S(L,K+1)*TVAR2N(L,K+1)
              ENDDO
            ENDDO
            DO K=1,KC
              DO L=2,LA
                SED(L,K,NS)=TVAR2N(L,K)
              ENDDO
            ENDDO
C
          ENDIF
C
C----------------------------------------------------------------------C
C
C **  FINAL FLUX KC=3
C
          DO L=2,LA
            SEDF(L,KC-1,NS)=DELTI*DZC(KC)*HP(L)*(SED(L,KC,NS)
     &                     -SEDS(L,KC,NS))
          ENDDO
          DO L=2,LA
            SEDF(L,1,NS)=DELTI*DZC(KC-1)*HP(L)*(SED(L,KC-1,NS)
     &                  -SEDS(L,KC-1,NS))+SEDF(L,KC-1,NS)
          ENDDO
C
C----------------------------------------------------------------------C
C
          ENDDO
        ENDIF
      ENDIF
C
C PT note: end of KC = 3 case.  Added extra ENDIF to call on SEDZLJ.
C**********************************************************************C
C
C **  COHESIVE SEDIMENT, KC.GT.3 (THREE OR MORE LAYERS IN VERTICAL)
C **  Sedflume Options Added
C     The whole loop has been modified to accomodate SEDZLJ
C     CAJ December, 2004
C
      IF(ISTRAN(6).GE.1.AND.KC.GT.3)THEN

      IF(NSEDFLUME.GT.0)THEN
         CALL SEDZLJ_MAIN

	 ELSE
C----------------------------------------------------------------------C
          DO NS=1,NSED
            DSEDGMM=1./(1.E6*SSG(NS))
C
C----------------------------------------------------------------------C
C
C **  SET SETTLING VELOCITIES
C
            IF(ISEDVW.EQ.0)THEN
              DO K=0,KS
                DO L=2,LA
                  WSETA(L,K,NS)=WSEDO(NS)
                ENDDO
              ENDDO
            ENDIF
C
            IF(ISEDVW.EQ.1)THEN
              DO K=0,KS
                DO L=2,LA
                  WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),0.0,ISEDVW)
                ENDDO
              ENDDO
            ENDIF
C
          IF(ISEDVW.EQ.2)THEN
            K=0
            DO L=2,LA
              TAUBC=QQ(L,0)/CTURB2
              UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
              VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
              CURANG=ATAN2(VTMP,UTMP)
              TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &             +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
              TAUB2=MAX(TAUB2,0.)
              STRESS=SQRT(TAUB2)
              SHEAR=2.*DZIC(K+1)*HPI(L)*SQRT(STRESS)/VKC
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),SHEAR,ISEDVW)
            ENDDO
            DO K=1,KS
              DO L=2,LA
                LN=LNC(L)
                SHEAR=HPI(L)*SQRT( DZIGSD4(K) )
     &              *SQRT( (U(LEAST(L),K+1)-U(LEAST(L),K)+U(L,K+1)-U(L,K))**2
     &                   +(V(LN ,K+1)-V(LN ,K)+V(L,K+1)-V(L,K))**2 )
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),SHEAR,ISEDVW)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISEDVW.GE.3)THEN
            K=0
            DO L=2,LA
              TAUBC=QQ(L,0)/CTURB2
              UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
              VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
              CURANG=ATAN2(VTMP,UTMP)
              TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &             +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
              TAUB2=MAX(TAUB2,0.)
              STRESS=SQRT(TAUB2)
              WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
            ENDDO
            DO K=1,KS
              DO L=2,LA
                LN=LNC(L)
                STRESS=AV(L,K)*SQRT( DZIGSD4(K) )
     &             *SQRT( (U(LEAST(L),K+1)-U(LEAST(L),K)+U(L,K+1)-U(L,K))**2
     &                   +(V(LN ,K+1)-V(LN ,K)+V(L,K+1)-V(L,K))**2 )
                WSETA(L,K,NS)=CSEDSET(L,SED(L,K+1,NS),STRESS,ISEDVW)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISEDVW.GE.3)THEN
            K=0
            L=857
            TAUBC=QQ(L,0)/CTURB2
            UTMP=0.5*STCUV(L)*(U(LEAST(L),1)+U(L,1))+1.E-12
            VTMP=0.5*STCUV(L)*(V(LNC(L),1)+V(L,1))
            CURANG=ATAN2(VTMP,UTMP)
            TAUB2=TAUBC*TAUBC+0.5*(QQWV2(L)*QQWV2(L))
     &            +FOURDPI*TAUBC*QQWV2(L)*COS(CURANG-WACCWE(L))
            TAUB2=MAX(TAUB2,0.)
            STRESSS(K)=SQRT(TAUB2)
            DO K=1,KS
              L=857
              LN=LNC(L)
              STRESSS(K)=AV(L,K)*SQRT( DZIGSD4(K) )
     &          *SQRT( (U(LEAST(L),K+1)-U(LEAST(L),K)+U(L,K+1)-U(L,K))**2
     &                +(V(LN ,K+1)-V(LN ,K)+V(L,K+1)-V(L,K))**2 )
            ENDDO
          ENDIF
C
C      WRITE(11,6111)TIME,(WSETA(857,K,1),K=0,KS)
C      WRITE(41,6111)TIME,(STRESSS(K),K=0,KS)
 6111 FORMAT(F10.2,10E12.4)
C
C----------------------------------------------------------------------C
C
C **  HORIZONTAL LOOPS
C
          K=KC
          DO L=2,LA
            SEDF(L,K,NS)=0.
            WVEL=DELT*HPI(L)*DZIC(K)
            CLEFT=1.+WSETA(L,K-1,NS)*WVEL
            CRIGHT=MAX(SED(L,K,NS),0.)
            SED(L,K,NS)=CRIGHT/CLEFT
            SEDF(L,K-1,NS)=-WSETA(L,K-1,NS)*SED(L,K,NS)
          ENDDO
C
          DO K=KS,2,-1
            DO L=2,LA
              WVEL=DELT*HPI(L)*DZIC(K)
              CLEFT=1.+WSETA(L,K-1,NS)*WVEL
              CRIGHT=MAX(SED(L,K,NS),0.)-SEDF(L,K,NS)*WVEL
              SED(L,K,NS)=CRIGHT/CLEFT
              SEDF(L,K-1,NS)=-WSETA(L,K-1,NS)*SED(L,K,NS)
            ENDDO
          ENDDO
C
          DO L=2,LA
            PROBDEP=0.
            WESE=0.
C **  SET MAXIMUM EROSION RATE
              WESEMX=DELTI*CTMPDRY(L)*SEDB(L,KBT(L),NS)
              WESEMX=MAX(WESEMX,0.)
              IF(TAUBSED(L).GT.TAURB(L,KBT(L)))THEN
C **  MASS EROSION
              WESE=CTMPDRY(L)*WRSPB(L,KBT(L))*VFRBED(L,KBT(L),NS)
              WESE=MIN(WESE,WESEMX)
            ELSE
              TAUE=0.
              IF(TAUBSED(L).GT.TAURS(L,KBT(L)))THEN
C **  SURFACE EROSION
                WESE=CTMPDRY(L)*WRSPS(L,KBT(L))*VFRBED(L,KBT(L),NS)
c1104                WESE=MIN(WESE,WESEMX)
                TAURTMP=TAURS(L,KBT(L))
	          IF(IWRSP(1).GE.2)TAURTMP=TAUR(1)
                TAUE=(TAUBSED(L)-TAURS(L,KBT(L)))/TAURTMP
                TAUE=MAX(TAUE,0.0)
                TMPSEDHID=1.0
                IF(ISTRAN(7).GE.1.AND.COSEDHID(1).NE.0.0)
     &            TMPSEDHID=(FRACCOH(L,KBT(L)))**COSEDHID(1)
                WESE=TMPSEDHID*WESE*(TAUE**TEXP(NS))
c1104
                WESE=MIN(WESE,WESEMX)
              ELSE
C **  NO EROSION
                WESE=0.0
              ENDIF
            ENDIF
C **  SET PROBABILITY OF DEPOSITION
              IF(TAUBSED(L).LT.TAUD(NS))
     &           PROBDEP=(TAUD(NS)-TAUBSED(L))/TAUD(NS)
              IF(SED(L,1,NS).GT.SEDMDGM) PROBDEP=1.
              WSETMP=PROBDEP*WSETA(L,0,NS)
              WVEL=DELT*HPI(L)*DZIC(1)
              CLEFT=1.+WSETMP*WVEL
              CRIGHT=MAX(SED(L,1,NS),0.)+(WESE-SEDF(L,1,NS))*WVEL
              SED(L,1,NS)=CRIGHT/CLEFT
              SEDF(L,0,NS)=-WSETMP*SED(L,1,NS)+WESE
              SEDBTMP=SEDB(L,KBT(L),NS)-DELT*SEDF(L,0,NS)
              IF(SEDBTMP.LT.0.0)THEN
                SEDF(L,0,NS)=DELTI*SEDB(L,KBT(L),NS)
                SEDBTMP=0.0
                SED(L,1,NS)=SEDS(L,1,NS)
     &                       +(SEDF(L,0,NS)-SEDF(L,1,NS))*WVEL
              ENDIF
              SEDB1(L,KBT(L),NS)=SEDB(L,KBT(L),NS)
              SEDB(L,KBT(L),NS)=SEDBTMP
              QSBDTOP(L)=QSBDTOP(L)+DSEDGMM*SEDF(L,0,NS)
              QWBDTOP(L)=QWBDTOP(L)+DSEDGMM*
     &               ( VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.)
     &                +VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.) )

          ENDDO
C
C----------------------------------------------------------------------C
C
C **  ANTI-DIFFUSION OF COHESIVE SEDIMENT  KC.GT.3
C
            IF(ISTOPT(6).EQ.1)THEN
C
              DO K=1,KS
                DO L=2,LA
                  CRNUM=1.+DELT*WSETA(L,K,NS)*HPI(L)*DZIC(K+1)
                  GRADSED=(SED(L,K+1,NS)-SED(L,K,NS))/(DZC(K+1)+DZC(K))
                  SEDAVG=0.5*(SED(L,K+1,NS)+SED(L,K,NS)+1.E-16)
                  WSETA(L,K,NS)=-CRNUM*DZC(K+1)*WSETA(L,K,NS)*
     &                        GRADSED/SEDAVG
                ENDDO
              ENDDO
C
C     TVAR1S=LOWER DIAGONAL
              DO L=2,LA
                TVAR1S(L,1)=0
              ENDDO
              DO K=2,KC
                DO L=2,LA
                  TVAR1S(L,K)=MIN(WSETA(L,K-1,NS),0.)
                ENDDO
              ENDDO
C
C     TVAR1N=UPPER DIAGONAL
              DO L=2,LA
                  TVAR1N(L,KC)=0
              ENDDO
              DO K=1,KS
                DO L=2,LA
                  TVAR1N(L,K)=-MAX(WSETA(L,K,NS),0.)
                ENDDO
              ENDDO
C     TVAR1W=MAIN DIAGONAL
              DO L=2,LA
                  TVAR1W(L,1)=DELTI*DZC(1)*HP(L)-MIN(WSETA(L,1,NS),0.)
                  TVAR1W(L,KC)=DELTI*DZC(KC)*HP(L)
     &                    +MAX(WSETA(L,KC-1,NS),0.)
              ENDDO
              DO K=2,KS
                DO L=2,LA
                  TVAR1W(L,K)=DELTI*DZC(KC)*HP(L)
     &              +MAX(WSETA(L,K-1,NS),0.)-MIN(WSETA(L,K,NS),0.)
                ENDDO
              ENDDO
C     TVAR1E=RIGHT HAND SIDE
              DO K=1,KC
                DO L=2,LA
                  TVAR1E(L,K)=DELTI*DZC(KC)*HP(L)*SED(L,K,NS)
                ENDDO
              ENDDO
C
C     TVAR3S=BET,TVAR2N=U,TVAR2S=GAM ARE WORKING ARRAYS
            DO L=2,LA
              TVAR3S(L)=TVAR1W(L,1)
            ENDDO
            DO L=2,LA
              TVAR2N(L,1)=TVAR1E(L,1)/TVAR3S(L)
            ENDDO
            DO K=2,KC
              DO L=2,LA
                TVAR2S(L,K)=TVAR1N(L,K-1)/TVAR3S(L)
                TVAR3S(L)=TVAR1W(L,K)-TVAR1S(L,K)*TVAR2S(L,K)
                TVAR2N(L,K)=(TVAR1E(L,K)-TVAR1S(L,K)*TVAR2N(L,K-1))/
     &                 TVAR3S(L)
              ENDDO
            ENDDO
            DO K=KS,1,-1
              DO L=2,LA
                TVAR2N(L,K)=TVAR2N(L,K)-TVAR2S(L,K+1)*TVAR2N(L,K+1)
              ENDDO
            ENDDO
            DO K=1,KC
              DO L=2,LA
                SED(L,K,NS)=TVAR2N(L,K)
              ENDDO
            ENDDO
C
            ENDIF
C
C----------------------------------------------------------------------C
C
C **  FINAL FLUX KC.GT.3
C
            DO L=2,LA
              SEDF(L,KS,NS)=DELTI*DZC(KC)*HP(L)*
     &                   (SED(L,KC,NS)-SEDS(L,KC,NS))
            ENDDO
C
            DO K=KS-1,1,-1
              DO L=2,LA
                SEDF(L,K,NS)=DELTI*DZC(K+1)*HP(L)*
     &                   (SED(L,K+1,NS)-SEDS(L,K+1,NS))+SEDF(L,K+1,NS)
              ENDDO
            ENDDO
C
C----------------------------------------------------------------------C
C
          ENDDO
        ENDIF
      ENDIF
C
C**********************************************************************C
C
C **  UNCOMMENT THE FOLLOWING FOR COHESIVE SEDIMENT DIAGNOSTICS
CDIAG           SEDMX=-1.E+12
CDIAG           SEDBMX=-1.E+12
CDIAG           SEDFMX=-1.E+12
CDIAG           SEDMN=1.E+12
CDIAG           SEDBMN=1.E+12
CDIAG           SEDFMN=1.E+12
CDIAG           DO K=1,KC
CDIAG            DO L=2,LA
CDIAG             IF(SED(L,K,NS).GT.SEDMX)THEN
CDIAG               LMX=L
CDIAG               KMX=K
CDIAG               SEDMX=SED(L,K,NS)
CDIAG             ENDIF
CDIAG             IF(SED(L,K,NS).LT.SEDMN)THEN
CDIAG               LMN=L
CDIAG               KMN=K
CDIAG               SEDMN=SED(L,K,NS)
CDIAG             ENDIF
CDIAG            ENDDO
CDIAG           ENDDO
CDIAG           DO L=2,LA
CDIAG            IF(SEDB(L,NS).GT.SEDBMX)THEN
CDIAG              LBMX=L
CDIAG              SEDBMX=SEDB(L,NS)
CDIAG            ENDIF
CDIAG            IF(SEDB(L,NS).LT.SEDBMN)THEN
CDIAG              LBMN=L
CDIAG              SEDBMN=SEDB(L,NS)
CDIAG            ENDIF
CDIAG            IF(SEDF(L,0,NS).GT.SEDFMX)THEN
CDIAG              LFMX=L
CDIAG              SEDFMX=SEDF(L,0,NS)
CDIAG            ENDIF
CDIAG            IF(SEDF(L,0,NS).LT.SEDFMN)THEN
CDIAG              LFMN=L
CDIAG              SEDFMN=SEDF(L,0,NS)
CDIAG            ENDIF
CDIAG           ENDDO
C
CDIAG      L=LMX
CDIAG      K=KMX
CDIAG      WRITE(1,101)N,NS,IL(L),JL(L),K,SED(L,K,NS),SEDS(L,K,NS)
CDIAG      L=LMN
CDIAG      K=KMN
CDIAG      WRITE(1,102)N,NS,IL(L),JL(L),K,SED(L,K,NS),SEDS(L,K,NS)
CDIAG      L=LBMX
CDIAG      WRITE(1,103)N,NS,IL(L),JL(L),SEDB(L,NS),SEDBS(L,NS),SEDF(L,0,NS)
CDIAG      L=LBMN
CDIAG      WRITE(1,104)N,NS,IL(L),JL(L),SEDB(L,NS),SEDBS(L,NS),SEDF(L,0,NS)
CDIAG      L=LFMX
CDIAG      WRITE(1,105)N,NS,IL(L),JL(L),SEDF(L,0,NS)
CDIAG      L=LFMN
CDIAG      WRITE(1,106)N,NS,IL(L),JL(L),SEDF(L,0,NS)
C
CDIAG  101 FORMAT(' N,NS,I,J,K,SEDMX,SEDSMX = ',5I5,4E13.4)
CDIAG  102 FORMAT(' N,NS,I,J,K,SEDMN,SEDSMN = ',5I5,4E13.4)
CDIAG  103 FORMAT(' N,NS,I,J,SEDBMX,SEDBSMX = ',4I5,4E13.4)
CDIAG  104 FORMAT(' N,NS,I,J,SEDBMN,SEDBSMN = ',4I5,4E13.4)
CDIAG  105 FORMAT(' N,NS,I,J,SEDFMX,SEDFSMX = ',4I5,4E13.4)
CDIAG  106 FORMAT(' N,NS,I,J,SEDFMN,SEDFSMN = ',4I5,4E13.4)
C
        OPEN(1,FILE='NEGSEDSND.OUT',POSITION='APPEND')
C
        DO NS=1,NSED
          DO K=1,KC
            DO L=2,LA
              IF(SED(L,K,NS).LT.-1.0)THEN
                WRITE(1,107)TIME,NS,IL(L),JL(L),K,SED(L,K,NS)
                PAUSE
              ENDIF
            ENDDO
          ENDDO
        ENDDO
C
        DO NS=1,NSED
          DO L=2,LA
            IF(SEDB(L,KBT(L),NS).LT.0.)THEN
              WRITE(1,108)TIME,NS,IL(L),JL(L),KBT(L),SEDB(L,KBT(L),NS),
     &             SEDF(L,0,NS)
              PAUSE
            ENDIF
          ENDDO
        ENDDO
C
        CLOSE(1)
C
C **  ACCUMULATE NET POSTIVE AND NEGATIVE COHESIVE SEDIMENT FLUXES
C
        DO NS=1,NSED
          DO L=2,LA
            SEDFDTAP(L,NS)=SEDFDTAP(L,NS)+DELT*MAX(SEDF(L,0,NS),0.0)
            SEDFDTAN(L,NS)=SEDFDTAN(L,NS)+DELT*MIN(SEDF(L,0,NS),0.0)
          ENDDO
        ENDDO
C
  107 FORMAT(' TIME,NS,I,J,K,NEGSED = ',F12.4,4I5,4E13.4)
  108 FORMAT(' TIME,NS,I,J,NEGSEDB,SEDF = ',F12.4,4I5,4E13.4)
C
C**********************************************************************C
C
      RETURN
      END


      LOGICAL FUNCTION AB13ID( JOBSYS, JOBEIG, EQUIL, CKSING, RESTOR,
     $                         UPDATE, N, M, P, A, LDA, E, LDE, B, LDB,
     $                         C, LDC, NR, RANKE, TOL, IWORK, DWORK,
     $                         LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To check whether the transfer function
C
C                                     -1
C       G(lambda) := C*( lambda*E - A ) *B
C
C     of a given linear time-invariant descriptor system with
C     generalized state space realization (lambda*E-A,B,C) is proper.
C     Optionally, if JOBEIG = 'A', the system (lambda*E-A,B,C) is
C     reduced to an equivalent one (lambda*Er-Ar,Br,Cr) with only
C     controllable and observable eigenvalues in order to use it for a
C     subsequent L_inf-norm computation; if JOBEIG = 'I', the system is
C     reduced to an equivalent one (lambda*Er-Ar,Br,Cr) without
C     uncontrollable and unobservable infinite eigenvalues. In this
C     case, intended mainly for checking the properness, the returned
C     system is not fully reduced, unless UPDATE = 'U'.
C
C     FUNCTION VALUE
C
C     AB13ID  LOGICAL
C             Indicates whether the transfer function is proper.
C             If AB13ID = .TRUE., the transfer function is proper;
C             otherwise, it is improper.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBSYS  CHARACTER*1
C             Indicates whether the system (lambda*E-A,B,C) is already
C             in the reduced form which is obtained as stated in
C             JOBEIG, as follows.
C             = 'R': The system is not in a reduced form, the reduction
C                    step is performed;
C             = 'N': The system is in a reduced form; the reduction step
C                    is omitted.
C
C     JOBEIG  CHARACTER*1
C             Indicates which kind of eigenvalues of the matrix pencil
C             lambda*E-A should be removed if JOBSYS = 'R', as follows:
C             = 'A': All uncontrollable and unobservable eigenvalues
C                    are removed; the reduced system is returned in
C                    the arrays A, E, B, C;
C             = 'I': Only all uncontrollable and unobservable infinite
C                    eigenvalues are removed; the returned system is not
C                    fully reduced if UPDATE = 'N'.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily scale
C             the system (lambda*E-A,B,C) as follows:
C             = 'S': Perform scaling;
C             = 'N': Do not perform scaling.
C
C     CKSING  CHARACTER*1
C             Specifies whether the user wishes to check if the pencil
C             (lambda*E-A) is singular as follows:
C             = 'C':  Check singularity;
C             = 'N':  Do not check singularity.
C             If the pencil is singular, the reduced system computed for
C             CKSING = 'N' may have completely different eigenvalues
C             than the given system.
C             The test is performed only if JOBSYS = 'R'.
C
C     RESTOR  CHARACTER*1
C             Specifies whether the user wishes to save the system
C             matrices before each reduction phase (if JOBSYS = 'R') and
C             restore them if no order reduction took place as follows:
C             = 'R':  Save and restore;
C             = 'N':  Do not save the matrices.
C             This option is ineffective if JOBSYS = 'N'.
C
C     UPDATE  CHARACTER*1
C             Specifies whether the user wishes to update the matrices
C             A, B, and C if JOBEIG = 'I' as follows:
C             = 'U':  Update the matrices A, B and C;
C             = 'N':  Do not update the matrices A, B and C when
C                     performing URV decomposition of the matrix E
C                     (see METHOD).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the descriptor state vector; also the
C             order of square matrices A and E, the number of rows of
C             matrix B, and the number of columns of matrix C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of the descriptor system input vector; also
C             the number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of the descriptor system output vector; also
C             the number of rows of matrix 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 state matrix A.
C             On exit, if JOBSYS = 'R' and JOBEIG = 'A', the leading
C             NR-by-NR part of this array contains the reduced order
C             state matrix Ar of a fully controllable and observable
C             realization for the original system. If JOBSYS = 'R' and
C             JOBEIG = 'I', the leading NR-by-NR part of this array
C             contains the reduced order state matrix Ar of a
C             transformed system without uncontrollable and unobservable
C             infinite poles. In this case, the matrix Ar does not
C             correspond to the returned matrix Er (obtained after a
C             URV decomposition), unless UPDATE = 'U' or RANKE < NR.
C             On exit, if JOBSYS = 'N' and (JOBEIG = 'A' or UPDATE = 'U'
C             or RANKE < N), the leading N-by-N part of this array
C             contains the transformed matrix A corresponding to the
C             URV decomposition of E (see (2) in METHOD), and if
C             JOBEIG = 'I' and UPDATE = 'N', the submatrix A22 in (2) is
C             further transformed to estimate its rank.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, if JOBSYS = 'R' and JOBEIG = 'A', the leading
C             NR-by-NR part of this array contains the reduced order
C             descriptor matrix Er of a completely controllable and
C             observable realization for the original system. The
C             reduced matrix Er is in upper triangular form.
C             If JOBSYS = 'R' and JOBEIG = 'I', the leading NR-by-NR
C             part of this array contains the reduced order descriptor
C             matrix Er of a transformed system without uncontrollable
C             and unobservable infinite poles. The reduced matrix Er is
C             upper triangular. In both cases, or if JOBSYS = 'N', the
C             matrix Er results from a URV decomposition of the matrix E
C             (see METHOD).
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,MAX(M,P))
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B; the remainder of the leading
C             N-by-MAX(M,P) part is used as internal workspace.
C             On exit, if JOBSYS = 'R' and JOBEIG = 'A', the leading
C             NR-by-M part of this array contains the reduced input
C             matrix Br of a completely controllable and observable
C             realization for the original system. If JOBSYS = 'R' and
C             JOBEIG = 'I', the leading NR-by-M part of this array
C             contains the transformed input matrix Br obtained after
C             removing the uncontrollable and unobservable infinite
C             poles; the transformations for the URV decomposition of
C             the matrix E are not applied if UPDATE = 'N'.
C             On exit, if JOBSYS = 'N' and (JOBEIG = 'A' or
C             UPDATE = 'U'), the leading N-by-M part of this array
C             contains the transformed matrix B corresponding to the
C             URV decomposition of E, but if JOBEIG = 'I', EQUIL = 'N'
C             and UPDATE = 'N', the array B is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
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 matrix C; the remainder of the leading
C             MAX(M,P)-by-N part is used as internal workspace.
C             On exit, if JOBSYS = 'R' and JOBEIG = 'A', the leading
C             P-by-NR part of this array contains the transformed output
C             matrix Cr of a completely controllable and observable
C             realization for the original system. If JOBSYS = 'R' and
C             JOBEIG = 'I', the leading P-by-NR part of this array
C             contains the transformed output matrix Cr obtained after
C             removing the uncontrollable and unobservable infinite
C             poles; the transformations for the URV decomposition of
C             the matrix E are not applied if UPDATE = 'N'.
C             On exit, if JOBSYS = 'N' and (JOBEIG = 'A' or
C             UPDATE = 'U'), the leading P-by-N part of this array
C             contains the transformed matrix C corresponding to the
C             URV decomposition of E, but if JOBEIG = 'I', EQUIL = 'N'
C             and UPDATE = 'N', the array C is unchanged on exit.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= MAX(1,M,P) if N > 0;
C             LDC >= 1          if N = 0.
C
C     NR      (output) INTEGER
C             The order of the reduced generalized state space
C             representation (lambda*Er-Ar,Br,Cr) as stated in JOBEIG.
C             If JOBEIG = 'A', NR denotes the order of a reduced system
C             without any uncontrollable or unobservable eigenvalues; if
C             JOBEIG = 'I', NR denotes the order of the reduced system
C             without any uncontrollable or unobservable infinite
C             eigenvalues. If JOBSYS = 'N', then NR = N.
C
C     RANKE   (output) INTEGER
C             The effective (estimated) rank of the reduced matrix Er.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION array, dimension 3
C             TOL(1) is the tolerance to be used in rank determinations
C             when transforming (lambda*E-A,B,C). If the user sets
C             TOL(1) > 0, then the given value of TOL(1) is used as a
C             lower bound for reciprocal condition numbers in rank
C             determinations; a (sub)matrix whose estimated condition
C             number is less than 1/TOL(1) is considered to be of full
C             rank.  If the user sets TOL(1) <= 0, then an implicitly
C             computed, default tolerance, defined by TOLDEF1 = N*N*EPS,
C             is used instead, where EPS is the machine precision (see
C             LAPACK Library routine DLAMCH).  TOL(1) < 1.
C             TOL(2) is the tolerance to be used for checking pencil
C             singularity when CKSING = 'C', or singularity of the
C             matrices A and E when CKSING = 'N'. If the user sets
C             TOL(2) > 0, then the given value of TOL(2) is used.
C             If the user sets TOL(2) <= 0, then an implicitly
C             computed, default tolerance, defined by  TOLDEF2 = 10*EPS,
C             is used instead.  TOL(2) < 1.
C             TOL(3) is the threshold value for magnitude of the matrix
C             elements, if EQUIL = 'S': elements with magnitude less
C             than or equal to TOL(3) are ignored for scaling. If the
C             user sets TOL(3) >= 0, then the given value of TOL(3) is
C             used. If the user sets TOL(3) < 0, then an implicitly
C             computed, default threshold, defined by  THRESH = c*EPS,
C             where c = MAX(norm_1(A,E,B,C)) is used instead.
C             TOL(3) = 0 is not always a good choice.  TOL(3) < 1.
C             TOL(3) is not used if EQUIL = 'N'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension LIWORK
C             If JOBSYS = 'R',  LIWORK >= 2*N+MAX(M,P)+7;
C             If JOBSYS = 'N',  LIWORK >= N.
C             If JOBSYS = 'R', the first 7 elements of IWORK contain
C             information on performed reduction and on structure of
C             resulting system matrices after removing the specified
C             eigenvalues (see the description of the parameter INFRED
C             of the SLICOT Library routine TG01JY).
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.
C             If JOBSYS = 'R', and EQUIL = 'S',
C                LDWORK >= MAX(w+4*N+4,8*N,x,y),
C             where w = N*N,                  if JOBEIG = 'A',
C                   w = 0,                    if JOBEIG = 'I',
C                   x = MAX(2*(z+MAX(M,P)+N-1),N*N+4*N), if RESTOR = 'R'
C                   x = MAX(  2*(MAX(M,P)+N-1),N*N+4*N), if RESTOR = 'N'
C                   y = 2*N*N+10*N+MAX(N,23), if CKSING = 'C',
C                   y = 0,                    if CKSING = 'N',
C                   z = 2*N*N+N*M+N*P;
C             if JOBSYS = 'R', and EQUIL = 'N',
C                LDWORK >= MAX(w+4*N+4,x,y);
C             if JOBSYS = 'N', and JOBEIG = 'A'  or UPDATE = 'U',
C                              and EQUIL  = 'S',
C                LDWORK >= MAX(N*N+4*N+4,8*N,N+M,N+P);
C             if JOBSYS = 'N', and JOBEIG = 'A'  or UPDATE = 'U',
C                              and EQUIL  = 'N',
C                LDWORK >= MAX(N*N+4*N+4,N+M,N+P);
C             if JOBSYS = 'N', and JOBEIG = 'I' and UPDATE = 'N',
C                              and EQUIL  = 'S',
C                LDWORK >= MAX(4*N+4,8*N);
C             if JOBSYS = 'N', and JOBEIG = 'I' and UPDATE = 'N',
C                              and EQUIL  = 'N',
C                LDWORK >= 4*N+4.
C             If JOBSYS = 'R' and ( RESTOR = 'R' or
C             LDWORK >= MAX(1,2*N*N+N*M+N*P+2*(MAX(M,P)+N-1) ),
C             then more accurate results are to be expected by
C             considering only those reduction phases in the SLICOT
C             Library routine TG01JY, where effective order reduction
C             occurs. This is achieved by saving the system matrices
C             before each phase (after orthogonally triangularizing the
C             matrix A or the matrix E, if RESTOR = 'N') and restoring
C             them if no order reduction took place. However, higher
C             global accuracy is not guaranteed.
C             For good performance, LDWORK should be generally larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA. The optimal workspace includes the
C             extra space for improving the accuracy.
C
C     Error/Warning Indicator
C
C     IWARN   INTEGER
C             = 0: When determining the rank of a matrix, the distance
C                  between the tolerance TOL(1) and the estimated
C                  singular values is sufficiently large. The rank can
C                  be safely determined;
C             = 1: When determining the rank of a matrix, there exist
C                  estimated singular values which are very close to the
C                  tolerance TOL(1). The computed rank is possibly
C                  incorrect.
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: the given pencil A - lambda*E is numerically
C                  singular and the reduced system is not computed.
C                  However, the system is considered improper, and
C                  AB13ID is set to .FALSE.
C                  This error can be returned only if CKSING = 'C'.
C
C     METHOD
C
C     If JOBSYS = 'R', the routine first removes uncontrollable and
C     unobservable infinite eigenvalues of the pencil lambda*E-A. If, in
C     addition, JOBEIG = 'A', uncontrollable and unobservable zero
C     eigenvalues are also removed. Then, or if JOBSYS = 'N', a
C     URV decomposition of the matrix E is performed, i.e., orthogonal
C     matrices U and V are computed, such that
C
C               ( T  0 )
C       U*E*V = (      ) with a full-rank matrix T.                  (1)
C               ( 0  0 )
C
C     Then the matrix A (or a copy of A if JOBEIG = 'A' or UPDATE = 'U')
C     is updated and partioned as in (1), i.e.,
C
C               ( A11  A12 )
C       U*A*V = (          ) ,                                       (2)
C               ( A21  A22 )
C
C     and the rank of A22 is computed. If A22 is invertible, the
C     transfer function is proper, otherwise it is improper. If
C     required (i.e., JOBEIG = 'A' or UPDATE = 'U'), the matrices B and
C     C are updated as well in order to obtain an equivalent reduced
C     system with the same transfer function. See also Chapter 3 in [1],
C     [2] for more details.
C
C     REFERENCES
C
C     [1] Voigt, M.
C         L_inf-Norm Computation for Descriptor Systems.
C         Diploma Thesis, Chemnitz University of Technology, Department
C         of Mathematics, Germany, July 2010.
C
C     [2] Benner, P., Sima, V., Voigt, M.
C         L_infinity-norm computation for continuous-time descriptor
C         systems using structured matrix pencils.
C         IEEE Trans. Automat. Contr., vol. 57, pp. 233-238, 2012.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O(N**3) floating point operations. During
C     the algorithm it is necessary to determine the rank of certain
C     matrices. Therefore it is crucial to use an appropriate tolerance
C     TOL(1) to make correct rank decisions.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Jan. 2012.
C     Based on the subroutine DGEISP by Matthias Voigt, Chemnitz
C     University of Technology, Department of Mathematics, Feb. 2010.
C
C     REVISIONS
C
C     V. Sima, Feb. 2012, March 2012, April 2012, June 2012.
C
C     KEYWORDS
C
C     Descriptor system, proper transfer function, L_inf-norm
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TEN
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1 )
C
C     .. Scalar Arguments ..
      CHARACTER          CKSING, EQUIL, JOBEIG, JOBSYS, RESTOR, UPDATE
      INTEGER            INFO, IWARN, LDA, LDB, LDC, LDE, LDWORK, M, N,
     $                   NR, P, RANKE
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ), E( LDE, * ), TOL( * )
C
C     .. Local Scalars ..
      CHARACTER          SYSTYP
      LOGICAL            LEQUIL, LQUERY, LREDC, LREMA, LRUPD, LSING,
     $                   LUPD, MAXACC
      INTEGER            I, ISV, ITAU, IWRK, IWS, J, K, MAXMP, MAXWRK,
     $                   MINWRK, N1, NA, RANKA
      DOUBLE PRECISION   PREC, SVLMAX, THRESH, TOLDEF
C
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 2 ), TOLV( 3 )
C
C     .. External Subroutines ..
      EXTERNAL           DLACPY, DLASET, DORMQR, DORMRZ, DSWAP, DTZRZF,
     $                   MB03OD, TG01AD, TG01JY, XERBLA
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, LSAME
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, MAX, MIN
C
C     .. Executable Statements ..
C
      INFO  = 0
      IWARN = 0
      MAXMP = MAX( M, P )
      N1    = MAX( 1, N )
C
C     Decode the input arguments.
C
      LREDC  = LSAME( JOBSYS, 'R' )
      LREMA  = LSAME( JOBEIG, 'A' )
      LEQUIL = LSAME( EQUIL,  'S' )
      LSING  = LSAME( CKSING, 'C' )
      MAXACC = LSAME( RESTOR, 'R' )
      LUPD   = LSAME( UPDATE, 'U' )
      LRUPD  = LREMA .OR. LUPD
C
C     Test the input arguments.
C
      IF( .NOT.LREDC .AND. .NOT.LSAME( JOBSYS, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LREMA  .AND. .NOT.LSAME( JOBEIG, 'I' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL,  'N' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LSING  .AND. .NOT.LSAME( CKSING, 'N' ) ) THEN
         INFO = -4
      ELSE IF( .NOT.MAXACC .AND. .NOT.LSAME( RESTOR, 'N' ) ) THEN
         INFO = -5
      ELSE IF( .NOT.LUPD   .AND. .NOT.LSAME( UPDATE, 'N' ) ) THEN
         INFO = -6
      ELSE IF( N.LT.0 ) THEN
         INFO = -7
      ELSE IF( M.LT.0 ) THEN
         INFO = -8
      ELSE IF( P.LT.0 ) THEN
         INFO = -9
      ELSE IF( LDA.LT.N1 ) THEN
         INFO = -11
      ELSE IF( LDE.LT.N1 ) THEN
         INFO = -13
      ELSE IF( LDB.LT.N1 ) THEN
         INFO = -15
      ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN
         INFO = -17
      ELSE IF( TOL( 1 ).GE.ONE ) THEN
         INFO = -20
      ELSE IF( TOL( 2 ).GE.ONE ) THEN
         INFO = -20
      ELSE IF( LEQUIL ) THEN
         THRESH = TOL( 3 )
         IF( THRESH.GE.ONE )
     $      INFO = -20
      END IF
      IF( INFO.EQ.0 ) THEN
C
C        Compute minimal workspace.
C
         IF( LREDC ) THEN
            K = N*( 2*N + M + P )
            IF( MAXACC ) THEN
               MINWRK = MAX( 1, 2*( K + MAXMP + N - 1 ) )
            ELSE
               MINWRK = MAX( 1, 2*( MAXMP + N - 1 ) )
            END IF
            MINWRK = MAX( MINWRK, N*N + 4*N )
            IF( LSING )
     $         MINWRK = MAX( MINWRK, 2*N*N + 10*N + MAX( N, 23 ) )
C
            IF( LREMA ) THEN
               SYSTYP = 'R'
            ELSE
               SYSTYP = 'P'
            END IF
         ELSE
            MINWRK = 0
         END IF
         IF( LRUPD ) THEN
            MINWRK = MAX( MINWRK, N*N + 4*N + 4, N + MAXMP )
         ELSE
            MINWRK = MAX( MINWRK, 4*N + 4 )
         END IF
         IF( LEQUIL )
     $      MINWRK = MAX( MINWRK, 8*N )
C
         MAXWRK = MINWRK
         LQUERY = LDWORK.EQ.-1
         IF( LQUERY ) THEN
C
C           Compute optimal workspace.
C
            IF( LREDC ) THEN
               CALL TG01JY( 'Irreducible', SYSTYP, 'No Scaling', CKSING,
     $                      RESTOR, N, M, P, A, LDA, E, LDE, B, LDB, C,
     $                      LDC, NR, IWORK, TOL, IWORK, DWORK, -1,
     $                      INFO )
               MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) )
            END IF
            CALL MB03OD( 'QR Decomposition', N, N, E, LDE, IWORK, TOL,
     $                   ZERO, DWORK, RANKE, DWORK, DUM, -1, INFO )
            MAXWRK = MAX( MAXWRK, INT( DUM( 1 ) ) + N + 3 )
            CALL DORMQR( 'Left', 'Transpose', N, N, N, E, LDE, DWORK, A,
     $                   LDA, DUM, -1, INFO )
            MAXWRK = MAX( MAXWRK, INT( DUM( 1 ) ) + N )
            IF( LRUPD ) THEN
               CALL DORMQR( 'Left', 'Transpose', N, M, N, E, LDE, DWORK,
     $                      B, LDB, DUM( 2 ), -1, INFO )
               MAXWRK = MAX( MAXWRK, INT( DUM( 2 ) ) + N )
            END IF
            CALL DTZRZF( N, N, E, LDE, DWORK, DUM, -1, INFO )
            CALL DORMRZ( 'Right', 'Transpose', N, N, N, N, E, LDE,
     $                   DWORK, A, LDA, DUM( 2 ), -1, INFO )
            MAXWRK = MAX( MAXWRK, MAX( INT( DUM( 1 ) ),
     $                                 INT( DUM( 2 ) ) ) + N )
            IF( LRUPD ) THEN
               CALL DORMRZ( 'Right', 'Transpose', P, N, N, N, E, LDE,
     $                      DWORK, C, LDC, DUM, -1, INFO )
               MAXWRK = MAX( MAXWRK, INT( DUM( 1 ) ) + N )
            END IF
         ELSE IF( LDWORK.LT.MINWRK ) THEN
            INFO = -23
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13ID', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK( 1 ) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      NR = N
      IF( N.EQ.0 ) THEN
         RANKE  = 0
         AB13ID = .TRUE.
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Set the tolerances.
C
      TOLDEF = TOL( 1 )
      IF( TOLDEF.LE.ZERO .OR. LEQUIL ) THEN
         PREC = DLAMCH( 'Precision' )
         IF( LEQUIL ) THEN
            IF( THRESH.LT.ZERO )
     $         THRESH = MAX( DLANGE( '1-norm', N, N, A, LDA, DWORK ),
     $                       DLANGE( '1-norm', N, N, E, LDE, DWORK ),
     $                       DLANGE( '1-norm', N, M, B, LDB, DWORK ),
     $                       DLANGE( '1-norm', P, N, C, LDC, DWORK ) )*
     $                  PREC
         ELSE
            TOLDEF = N*N*PREC
         END IF
      END IF
      TOLV( 1 ) = TOLDEF
      TOLV( 2 ) = TOL( 2 )
      TOLV( 3 ) = TOL( 3 )
C
C     Computations.
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
C     Equilibrate the system, if required.
C
C     Workspace: need   8*N.
C
      IF( LEQUIL ) THEN
         CALL TG01AD( 'All', N, N, M, P, THRESH, A, LDA, E, LDE, B, LDB,
     $                C, LDC, DWORK, DWORK( N+1 ), DWORK( 2*N+1 ),
     $                INFO )
         MAXWRK = MAX( MAXWRK, 8*N )
      END IF
C
      IF( LREDC ) THEN
C
C        Step 1: If JOBEIG = 'A' remove all uncontrollable and
C                unobservable eigenvalues of the system; otherwise
C                remove only the uncontrollable and unobservable
C                infinite eigenvalues explicitely, uncontrollable or
C                unobservable zero eigenvalues are not removed.
C
C        Workspace: need   MAX(2*(MAX(M,P)+N-1),N*N+4*N,y),
C                   prefer MAX(2*N*N+N*M+N*P+2*(MAX(M,P)+N-1),y), or
C                          even larger (see, optimal space above).
C
         IWS = 8
         CALL TG01JY( 'Irreducible', SYSTYP, 'No Scaling', CKSING,
     $                RESTOR, N, M, P, A, LDA, E, LDE, B, LDB, C, LDC,
     $                NR, IWORK, TOLV, IWORK( IWS ), DWORK, LDWORK,
     $                INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) )
         IF( INFO.EQ.1 ) THEN
            AB13ID = .FALSE.
            RETURN
         END IF
      ELSE
         IWS = 1
      END IF
C
C     Step 2: Compute a URV decomposition of E(1:NR,1:NR).
C
      DO 10 I = IWS, IWS + NR - 1
         IWORK( I ) = 0
   10 CONTINUE
C
C     Perform a rank-revealing QR decomposition of E(1:NR,1:NR) with
C     respect to the tolerance TOLDEF.
C
C     Workspace: need   4*NR+4,
C                prefer 3*NR+( NR+1 )*NB+3, with NB for DGEQP3.
C
      SVLMAX = DLANGE( 'Frobenius', N, N, E, LDE, DWORK )
      CALL MB03OD( 'QR Decomposition', NR, NR, E, LDE, IWORK( IWS ),
     $             TOLDEF, SVLMAX, DWORK, RANKE, DWORK( NR+1 ),
     $             DWORK( NR+4 ), LDWORK-( NR+3 ), INFO )
      MAXWRK = MAX( MAXWRK, INT( DWORK( NR+4 ) ) + NR + 3 )
C
C     Check whether there are singular values close to the tolerance
C     TOLDEF.
C
      IF( MIN( ABS( DWORK( NR+2 ) - TOLDEF ),
     $         ABS( DWORK( NR+3 ) - TOLDEF ) ) .LT.TOLDEF/TEN )
C
C        One singular value is close to TOLDEF, warning returned.
C
     $   IWARN = 1
C
      IF( RANKE.LT.NR .OR. LRUPD ) THEN
C
C        Perform the same transformations on A(1:NR,1:NR).
C
C        Workspace: need   2*NR,
C                   prefer NR+NR*( NB+1 ).
C
         CALL DORMQR( 'Left', 'Transpose', NR, NR, NR, E, LDE, DWORK, A,
     $                LDA, DWORK( NR+1 ), LDWORK-NR, INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( NR+1 ) ) + NR )
C
         DO 20 I = IWS, IWS + NR - 1
            IWORK( I ) = -IWORK( I )
   20    CONTINUE
C
         DO 40 I = IWS, IWS + NR - 1
            IF( IWORK( I ).LT.0 ) THEN
               J = I
               IWORK( J ) = -IWORK( J )
   30          CONTINUE
               K = IWORK( J ) + IWS - 1
               IF( IWORK( K ).LT.0 ) THEN
                  CALL DSWAP( NR, A( 1, J-IWS+1 ), 1, A( 1, K-IWS+1 ),
     $                        1 )
                  IWORK( K ) = -IWORK( K )
                  J = K
                  GO TO 30
               END IF
            END IF
   40    CONTINUE
C
         IF( LRUPD ) THEN
C
C           Update B and C.
C
C           Workspace: need   NR+M,
C                      prefer NR+M*NB.
C
            CALL DORMQR( 'Left', 'Transpose', NR, M, NR, E, LDE, DWORK,
     $                   B, LDB, DWORK( NR+1 ), LDWORK-NR, INFO )
            MAXWRK = MAX( MAXWRK, INT( DWORK( NR+1 ) ) + NR )
C
            DO 50 I = IWS, IWS + NR - 1
               IWORK( I ) = -IWORK( I )
   50       CONTINUE
C
            DO 70 I = IWS, IWS + NR - 1
               IF( IWORK( I ).LT.0 ) THEN
                  J = I
                  IWORK( J ) = -IWORK( J )
   60             CONTINUE
                  K = IWORK( J ) + IWS - 1
                  IF( IWORK( K ).LT.0 ) THEN
                     CALL DSWAP( P, C( 1, J-IWS+1 ), 1, C( 1, K-IWS+1 ),
     $                           1 )
                     IWORK( K ) = -IWORK( K )
                     J = K
                     GO TO 60
                  END IF
               END IF
   70       CONTINUE
         END IF
      END IF
C
C                                        ( R11 R12 )
C     Logically partition E(1:NR,1:NR) = (         ),
C                                        (  0  R22 )
C
C     where R11 = R(1:RANKE,1:RANKE).
C
C     Neglect R22 and annihilate R12.
C
      IF( RANKE.LT.NR ) THEN
C
C        The block R22 is non-empty, further computations required.
C
C        Workspace: need   2*RANKE,
C                   prefer RANKE+RANKE*NB.
C
         CALL DTZRZF( RANKE, NR, E, LDE, DWORK, DWORK( RANKE+1 ),
     $                LDWORK-RANKE, INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( RANKE+1 ) ) + RANKE )
C
C        Perform the same transformations on A(1:NR,1:NR).
C
C        Workspace: need   RANKE+NR,
C                   prefer RANKE+NR*NB.
C
         NA = NR - RANKE
         CALL DORMRZ( 'Right', 'Transpose', NR, NR, RANKE, NA, E, LDE,
     $                DWORK, A, LDA, DWORK( RANKE+1 ), LDWORK-RANKE,
     $                INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( RANKE+1 ) ) + RANKE )
C
         IF( LRUPD ) THEN
C
C           Update C.
C
C           Workspace: need   RANKE+P,
C                      prefer RANKE+P*NB.
C
            CALL DORMRZ( 'Right', 'Transpose', P, NR, RANKE, NA, E, LDE,
     $                   DWORK, C, LDC, DWORK( RANKE+1 ), LDWORK-RANKE,
     $                   INFO )
            MAXWRK = MAX( MAXWRK, INT( DWORK( RANKE+1 ) ) + RANKE )
         END IF
C
C        Step 3: Determine the rank of A(RANKE+1:NR,RANKE+1:NR).
C
         DO 80 I = IWS, IWS + NA - 1
            IWORK( I ) = 0
   80    CONTINUE
C
C        Perform a rank-revealing QR decomposition of
C        A(RANKE+1:NR,RANKE+1:NR) with respect to the tolerance TOLDEF.
C
         SVLMAX = DLANGE( 'Frobenius', NR, NR, A, LDA, DWORK )
C
         IF( LRUPD ) THEN
C
C           IF JOBEIG = 'A' or UPDATE = 'U', then copy
C           A(RANKE+1:NR,RANKE+1:NR) to DWORK and perform the operations
C           on DWORK.
C
C           Workspace: need   NA*NA+4*NA+4,
C                      prefer NA*NA+3*NA+( NA+1 )*NB+3.
C
            ITAU = NA*NA + 1
            ISV  = ITAU  + NA
            IWRK = ISV   + 3
            CALL DLACPY( 'Full', NA, NA, A( RANKE+1, RANKE+1 ), LDA,
     $                   DWORK, NA )
            CALL MB03OD( 'QR Decomposition', NA, NA, DWORK, NA,
     $                   IWORK( IWS ), TOLDEF, SVLMAX, DWORK( ITAU ),
     $                   RANKA, DWORK( ISV ), DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
         ELSE
C
C           Workspace: need   4*NA+4,
C                      prefer 3*NA+( NA+1 )*NB+3.
C
            ISV  = NA  + 1
            IWRK = ISV + 3
            CALL MB03OD( 'QR Decomposition', NA, NA,
     $                   A( RANKE+1, RANKE+1 ), LDA, IWORK( IWS ),
     $                   TOLDEF, SVLMAX, DWORK, RANKA, DWORK( ISV ),
     $                   DWORK( IWRK ), LDWORK-IWRK+1, INFO )
         END IF
C
         MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C        Check whether there are singular values close to the
C        tolerance TOLDEF.
C
         IF( MIN( ABS( DWORK( ISV+1 ) - TOLDEF ),
     $            ABS( DWORK( ISV+2 ) - TOLDEF ) ).LT.TOLDEF/TEN )
C
C           One singular value is close to TOLDEF, warning returned.
C
     $      IWARN = 1
C
C        Set R12 to 0.
C
         IF( NA.GT.0 )
     $      CALL DLASET( 'Full', RANKE, NA, ZERO, ZERO, E( 1, RANKE+1 ),
     $                   LDE )
      ELSE
C
C        The block R22 is empty, no computation required.
C
         RANKA = 0
         NA    = 0
      END IF
C
C     Set the lower triangle of T in (1) to 0.
C
      IF( NR.GT.1 )
     $   CALL DLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, E( 2, 1 ), LDE )
C
C     Step 4: Determine if the transfer function is proper.
C
      IF( NA.EQ.RANKA ) THEN
C
C        The transfer function is proper.
C
         AB13ID = .TRUE.
      ELSE
C
C        The transfer function is improper.
C
         AB13ID = .FALSE.
      END IF
C
      DWORK( 1 ) = MAXWRK
      RETURN
C *** Last line of AB13ID ***
      END


*DECK ZLOG
      SUBROUTINE ZLOG (AR, AI, BR, BI, IERR)
C***BEGIN PROLOGUE  ZLOG
C***SUBSIDIARY
C***PURPOSE  Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and
C            ZBIRY
C***LIBRARY   SLATEC
C***TYPE      ALL (ZLOG-A)
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C     DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A)
C     IERR=0,NORMAL RETURN      IERR=1, Z=CMPLX(0.0,0.0)
C***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY
C***ROUTINES CALLED  ZABS
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  ZLOG
      DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI
      DOUBLE PRECISION ZABS
      INTEGER IERR
      EXTERNAL ZABS
      DATA DPI , DHPI  / 3.141592653589793238462643383D+0,
     1                   1.570796326794896619231321696D+0/
C***FIRST EXECUTABLE STATEMENT  ZLOG
      IERR=0
      IF (AR.EQ.0.0D+0) GO TO 10
      IF (AI.EQ.0.0D+0) GO TO 20
      DTHETA = DATAN(AI/AR)
      IF (DTHETA.LE.0.0D+0) GO TO 40
      IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI
      GO TO 50
   10 IF (AI.EQ.0.0D+0) GO TO 60
      BI = DHPI
      BR = LOG(ABS(AI))
      IF (AI.LT.0.0D+0) BI = -BI
      RETURN
   20 IF (AR.GT.0.0D+0) GO TO 30
      BR = LOG(ABS(AR))
      BI = DPI
      RETURN
   30 BR = LOG(AR)
      BI = 0.0D+0
      RETURN
   40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
   50 ZM = ZABS(AR,AI)
      BR = LOG(ZM)
      BI = DTHETA
      RETURN
   60 CONTINUE
      IERR=1
      RETURN
      END


module accel
use variables
use statis
use maths
implicit none
contains
! *********************************************************
! *********************************************************
! ACCELERATION ROUTINES
! *********************************************************
! *********************************************************

!-----------------------------------------------------------------
! Executes acceleration if they are activated (Ng)
!-----------------------------------------------------------------
	subroutine aceleracion

		if (iacel == 1 .and. itracc > 0) then
			if (ng(pop,nl*n_radios,nord,scratch)) then
				print *, 'Ng acceleration'
				itracc = -nintracc
			endif
		endif

	end subroutine aceleracion

! ---------------------------------------------------------
! Performs an Ng acceleration of the solution
! ---------------------------------------------------------

	function ng(y,m,n,yy)
	logical :: ng, ng0
	integer, INTENT(IN) :: n, m
	real(kind=8), INTENT(INOUT) :: y(m), yy(m,*)
	real(kind=8) :: A(7,7), C(7), di, dy, wt
	integer :: k, i, j
	integer, save :: ntry
	data ntry /0/

	if (n < 1 .or. n > 5) return
	ntry = ntry + 1
	yy(:,ntry) = y
	ng = .false.
	if (ntry <= n+1) return

	A = 0.d0 ; C = 0.d0

	do k = 1, m
		wt = 1.d0 / (1.d0 + dabs(y(k)))
		do i = 1, n
			dy = yy(k,ntry-1) - yy(k,ntry)
			di = wt * (dy + yy(k,ntry-i) - yy(k,ntry-i-1) )
			c(i) = c(i) + di*dy
			do j = 1, n
				A(i,j) = A(i,j) + di * (dy + yy(k,ntry-j) - yy(k,ntry-j-1) )
			enddo !j
		enddo !i
	enddo !k

	call llslv(A,C,n,7)

	ng = .true.
	do i = 1, n
		y(:) = y(:) + c(i) * ( yy(:,ntry-i) - yy(:,ntry) )
	enddo !i

	entry ng0
	ntry = 0

	end function ng
end module accel


!----------------------------------------------------------------------*
!  SUBROUTINE TSHIFT                                                   *
!  Purpose: This subroutine calculates the shift of daily average	   *
!			temperature and the change of heat unit due to air		   *
!           temperature is controlled in a period of a day			   *
!           Author: Tao Li, IRRI, June 5, 509.						   *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning (unit)                                     class *
! ----   ---- ---------------                                    ----- *
! TMAX    R4  Daily maximum temperature (oC)                        I  *
! TMIN    R4  Daily minimum temperature (oC)                        I  *
! DOYC    R4  The day in a year at temperature is controlled        I  *
! SHOUR   R4  The starting hour of temperature control (24 base)    I  *
! EHOUR   R4  The ending hour of temperature control				I  *
! TTEMP	  R4  The target controlled temperature                     I  *
! TCHANG  R4  The net change of temperature during control          I  *
! TBD     R4  Base temperature for development (oC)                 I  *
! TOD     R4  Optimum temperature for development (oC)              I  *
! TMD     R4  Maximum temperature for development (oC)              I  *
! HU      R4  Heat units (oCd d-1)                                  O  *
! xTAV	  R4  Shifted amount of average temperature					O  *
! xTMIN   R4  Shifted amount of minimum temperature                 O  *
! xTMAX   R4  Shifted amount of maximum temperature                 O  *
! xHU     R4  Shifted amount of thermal unit                        O  *
!                                                                      *
!  FILE usage : none                                                   *
! If TTEMP is a number larger than -999, then TCHANG must be set -999, *
!  or in reverse way. Only one number is used to calculate the shifting*
!----------------------------------------------------------------------*
      SUBROUTINE TSHIFT(TMAX,TMIN,DAYL, SHOUR, EHOUR, TTEMP, TCHANG, &
		ISTEMPC, CONTRM, TBD,TOD,TMD,HU2, xTAV, xTMIN, xTMAX, xHU, xTAVD)

      IMPLICIT NONE
!-----Formal parameters
      REAL    TMAX,TMIN,TBD,TOD,TMD,HU2, xHU
	  REAL DAYL, SHOUR, EHOUR, TTEMP, TCHANG, xTAV, xTMIN, xTMAX, xTAVD
!-----Local parameters
      REAL    TD, TM, TT, DST, DET, TMPV !, DAVERT
	  REAL   MYT(24)  !,MYTEM
      INTEGER I, ISTEMPC, CONTRM
      SAVE         !&#@TAOLI
!Calculate hourly temperature
	  TM = (TMAX+TMIN)/2.
      DO I = 1,24
		 MYT(I) = 0.0
         TD = TM+0.5*ABS(TMAX-TMIN)*COS(0.2618*FLOAT(I-14))
		 MYT(I) = TD
		 IF ((TD.GT.TBD).AND.(TD.LT.TMD)) THEN
            IF (TD.GT.TOD) TD = TOD-(TD-TOD)*(TOD-TBD)/(TMD-TOD)
            TT = TT+(TD-TBD)/24.
         END IF
      END DO
	  HU2=TT
!Impose the temperature variation into target period
	  DO I = 1, 24
		 IF(ISTEMPC.EQ.2) THEN
			IF((I.GE.SHOUR).AND.(I.LE.EHOUR)) THEN
				IF((TTEMP.NE.-999.0).AND.(TCHANG.EQ.-999.0)) THEN
					IF(CONTRM.EQ.1) THEN
						IF(MYT(I).LT.TTEMP) MYT(I) = TTEMP
					ELSEIF(CONTRM.EQ.2) THEN
						MYT(I) = TTEMP
					ENDIF
				ELSEIF((TTEMP.EQ.-999.0).AND.(TCHANG.NE.-999.0)) THEN
					MYT(I) = MYT(I) + TCHANG
				ENDIF
			ENDIF
		ELSEIF(ISTEMPC.EQ.1) THEN
			IF(((I.GE.0).AND.(I.LE.EHOUR)).OR.((I.GE.SHOUR).AND.(I.LE.24))) THEN
				IF((TTEMP.NE.-999.0).AND.(TCHANG.EQ.-999.0)) THEN
					IF(CONTRM.EQ.1) THEN
						IF(MYT(I).LT.TTEMP) MYT(I) = TTEMP
					ELSEIF(CONTRM.EQ.2) THEN
						MYT(I) = TTEMP
					ENDIF
				ELSEIF((TTEMP.EQ.-999.0).AND.(TCHANG.NE.-999.0)) THEN
					MYT(I) = MYT(I) + TCHANG
				ENDIF
			ENDIF
		ENDIF
	  ENDDO
!Check whether the max and min temperature changed, and calculate the average temperature
	  XTAV=0.0; XTMIN = TMIN; XTMAX = TMAX
	  DO I = 1, 24
		 IF(MYT(I).GT.TMAX) XTMAX = MYT(I)
		 IF(MYT(I).LT.TMIN) XTMIN = MYT(I)
		 XTAV = XTAV + MYT(I)
	  ENDDO
	  XTAV = XTAV/24.0 - TM
	  XTMIN = XTMIN - TMIN
	  XTMAX = XTMAX - TMAX

!Calculate the thermal unit
      TT = 0.
      DO I = 1,24
         TD = MYT(I)
         IF ((TD.GT.TBD).AND.(TD.LT.TMD)) THEN
            IF (TD.GT.TOD) TD = TOD-(TD-TOD)*(TOD-TBD)/(TMD-TOD)
            TT = TT+(TD-TBD)/24.
         END IF

      END DO
      xHU = TT - HU2
!CALCULATE THE ACTUAL DAY TIME AVERAGE
	  DST = 12.0 - DAYL/2.0; DET = 12.0 + DAYL/2.0; XTAVD = 0.0
	  DO I = 1, 24
		 IF((I.GE.DST).AND.(I.LE.DET)) THEN
			XTAVD = XTAVD + MYT(I)
		 ENDIF
      ENDDO
	  XTAVD = XTAVD/(DET-DST)
	  TMPV  = (TMIN+TMAX)/2.
      TMPV = (TMAX+TMPV )/2.
	  XTAVD = XTAVD - TMPV

      RETURN
      END


! ###########################################################
! #                                                         #
! #                    THE LIDORT FAMILY                    #
! #                                                         #
! #      (LInearized Discrete Ordinate Radiative Transfer)  #
! #       --         -        -        -         -          #
! #                                                         #
! ###########################################################

! ###########################################################
! #                                                         #
! #  Author :      Robert. J. D. Spurr                      #
! #                                                         #
! #  Address :     RT Solutions, Inc.                       #
! #                9 Channing Street                        #
! #                Cambridge, MA 02138, USA                 #
! #                                                         #
! #  Tel:          (617) 492 1183                           #
! #  Email :        rtsolutions@verizon.net                 #
! #                                                         #
! ###########################################################

! ###########################################################
! #                                                         #
! #     FIRST-ORDER VECTOR MODEL (EXACT SINGLE SCATTERING)  #
! #                                                         #
! #  This Version :   1.3 F90                               #
! #  Release Date :   March 2013                            #
! #                                                         #
! #   Version 1.1,  13 February 2012, First Code            #
! #   Version 1.2,  01 June     2012, Modularization        #
! #   Version 1.3,  29 October  2012, Multiple geometries   #
! #                                                         #
! ###########################################################

! ##########################################################
! #                                                        #
! #   This Version of FIRST_ORDER comes with a GNU-style   #
! #   license. Please read the license carefully.          #
! #                                                        #
! ##########################################################

! ###############################################################
! #                                                             #
! #    Taylor series, small number expansions:                  #
! #             TAYLOR_SERIES_1                                 #
! #                                                             #
! ###############################################################

MODULE FO_Taylor_m

IMPLICIT NONE

PRIVATE

!  parameter arguments

      INTEGER, PARAMETER   :: fpk = selected_real_kind(15)

      REAL(FPK), PARAMETER :: one  = 1.0_fpk,&
                              half = 0.5_fpk

      REAL(FPK), PARAMETER :: taylor_small = 0.0001_fpk
      REAL(FPK), PARAMETER :: taylor_large = 10000.0_fpk

PUBLIC :: taylor_series_1,&
          taylor_series_L_1,&
          taylor_small,&
          taylor_large

CONTAINS

SUBROUTINE TAYLOR_SERIES_1 &
          ( EPS, DELTA, TERM2, MULT )

!  Good for the particular and homogeneous-solution multipliers.
!      Small number expansion to second order

!  Note: In LIDORT, this subroutine is applied to quantities of the form
!                [exp(-b*DELTA) - exp(-a*DELTA)]
!            q = -------------------------------
!                            (a-b)
!        where (a-b) has become small to the point of causing instability.
!        Note the positions of "a" and "b" in the numerator are swapped
!        from their positions in the denominator.
!
!        Using the above form for "q", the I/O for the subroutine is as
!        follows:
!        * EPS   = (a-b)
!        * DELTA = optical thickness (whole or partial layer)
!        * TERM2 = exp(-a*DELTA) (usually UDEL or WDEL)
!        * MULT  = q

      IMPLICIT NONE

!  input arguments

      REAL(FPK), INTENT(IN)  :: eps, delta, term2

!  output arguments

      REAL(FPK), INTENT(OUT) :: mult

!  local declarations

      REAL(FPK) :: power, power2

!test write

      !write(*,*) 'using TAYLOR_SERIES_1'

!  evaluate

      power  = delta*eps
      power2 = power**2
      mult   = term2*delta*(one + half*power + power2/6.0_fpk)

!  Finish

END SUBROUTINE TAYLOR_SERIES_1

!

SUBROUTINE TAYLOR_SERIES_L_1 &
          ( EPS, DELTA, TERM2, L_DELTA, L_TERM2, L_MULT )

!  Good for the particular and homogeneous-solution multipliers.
!      Small number expansion to second order

!  Note: In LIDORT, this subroutine is applied to quantities of the form
!                [exp(-b*DELTA) - exp(-a*DELTA)]
!            q = -------------------------------
!                            (a-b)
!        where (a-b) has become small to the point of causing instability.
!        Note the positions of "a" and "b" in the numerator are swapped
!        from their positions in the denominator.
!
!        Using the above form for "q", the I/O for the subroutine is as
!        follows:
!        * EPS   = (a-b)
!        * DELTA = optical thickness (whole or partial layer)
!        * TERM2 = exp(-a*DELTA) (usually UDEL or WDEL)
!        * MULT  = q
!
!  In this subroutine, the 2nd-order Taylor polynomial for "q" from the
!  subroutine TAYLOR_SERIES_1 has been linearized; thus, the linearized input
!  quantities L_DELTA and L_TERM2 associated with DELTA and TERM2 are also
!  present.

      IMPLICIT NONE

!  input arguments

      REAL(FPK), INTENT(IN)  :: eps, delta, term2, L_delta, L_term2

!  output arguments

      REAL(FPK), INTENT(OUT) :: L_mult

!  local declarations

      REAL(FPK) :: power, power2

!test write

      !write(*,*) 'using TAYLOR_SERIES_L_1'

!  evaluate

      power  = delta*eps
      power2 = power**2
      L_mult = L_term2*delta*(one + half*power + power2/6.0_fpk) &
             + term2*L_delta*(one +      power + half*power2   )

!  Finish

END SUBROUTINE TAYLOR_SERIES_L_1

!  ####################################################################

!  Finish module

END MODULE FO_Taylor_m