SUBROUTINE MORPHJ
  
  ! REVISION DATE :  May 24, 2006
  !  Craig Jones and Scott James
  !***************************************************************
  USE GLOBAL
  IMPLICIT NONE
  !REAL::TMPVAL
  !INTEGER::ITMP,K,L,LL,NS,NT
  !REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DELBED  
  DOUBLE PRECISION::TMPVAL
  INTEGER::ITMP,K,L,LL,NS,NT
  !PT: real value are written in DOUBLE PRECISION. 7/16/08
  DOUBLE PRECISION,SAVE,ALLOCATABLE,DIMENSION(:)::DELBED 
  IF(.NOT.ALLOCATED(DELBED)) THEN
     ALLOCATE(DELBED(LCM)) 
     DELBED=0.0
  ENDIF
  DO L=2,LA
     DELBED(L)=0.01*SUM(TSED(1:KB,L)/BULKDENS(1:KB,L))-HBEDA(L)
     BELV1(L)=BELV(L)  
     HTMP(L)=HP(L)  
     H1P(L)=HP(L)  
     P1(L)=P(L)
     HBEDA(L)=0.01*SUM(TSED(1:KB,L)/BULKDENS(1:KB,L))
     HBED(L,1:KB)=0.01*TSED(1:KB,L)/BULKDENS(1:KB,L)
     BELV(L)=ZELBEDA(L)+HBEDA(L) 
     HP(L)=HP(L)+DELBED(L) 
  ENDDO
  !print*,0.01*SUM(TSED(1:KB,2:LA)/BULKDENS(1:KB,2:LA)),sum(belv(2:LA)),sum(hp(2:LA)),sum(delbed(2:la))
  DO L=2,LA
     HPI(L)=1.0/HP(L)  
     QMORPH(L)=DELTI*DXYP(L)*(HP(L)-H1P(L))  
  ENDDO
  ITMP=0  
  DO L=2,LA  
     IF(HP(L)<=0.0) THEN  
        IF(ABS(H1P(L))>=HWET) THEN  
           ITMP=1  
           WRITE(8,"('NEG DEPTH DUE TO MORPH CHANGE', 2I5,12F12.5)")IL(L),JL(L),HBED1(L,KBT(L)),HBED(L,KBT(L)),BELV1(L),BELV(L),DELT,QSBDTOP(L),QWBDTOP(L),HBEDA(L)  
           WRITE(8,"('NEG DEPTH DUE TO MORPH CHANGE', 2I5,12F12.5)")L,KBT(L),(HBED(L,K),K=1,KBT(L))  
        ELSE  
           HP(L)=0.9*HDRY  
        ENDIF
     ENDIF
  ENDDO
  IF(ITMP==1) THEN  
     CALL RESTOUT(1)  
     IF(NDRYSTP<0) THEN
        OPEN(1,FILE='DRYLOSS.OUT')
        CLOSE(1,STATUS='DELETE')
        OPEN(1,FILE='DRYLOSS.OUT')
        DO L=2,LA
           IF(VDWASTE(L)>0.0) THEN
              TMPVAL=VDWASTE(L)/DXYP(L)
              WRITE(1,'(2I6,4E14.6)')IL(L),JL(L),VDWASTE(L),TMPVAL,QDWASTE(L)
           ENDIF
        ENDDO
        CLOSE(1)
     ENDIF
     STOP  
  ENDIF
  
  ! ++  ADJUST CONCENTRATIONS OF TRANSPORT VARIABLES IN RESPONSE TO  
  ! ++  CHANGE IN BED MORPHOLOGY  
  
  IF(ISTRAN(1)>0)FORALL(K=1:KC,L=2:LA)SAL(L,K)=HTMP(L)*SAL(L,K)/HP(L)  
  IF(ISTRAN(2)>0)FORALL(K=1:KC,L=2:LA)TEM(L,K)=HTMP(L)*TEM(L,K)/HP(L)  
  IF(ISTRAN(3)>0)FORALL(K=1:KC,L=2:LA)DYE(L,K)=HTMP(L)*DYE(L,K)/HP(L)  
  IF(ISTRAN(4)>0)FORALL(K=1:KC,L=2:LA)SFL(L,K)=HTMP(L)*SFL(L,K)/HP(L)  
  IF(ISTRAN(5)>0)FORALL(NT=1:NTOX,K=1:KC,L=2:LA)TOX(L,K,NT)=HTMP(L)*TOX(L,K,NT)/HP(L)  
  IF(ISTRAN(6)>0)FORALL(NS=1:NSCM,K=1:KC,L=2:LA)SED(L,K,NS)=HTMP(L)*SED(L,K,NS)/HP(L)  
  IF(ISTRAN(7)>0)FORALL(NS=1:NSND,K=1:KC,L=2:LA)SND(L,K,NS)=HTMP(L)*SND(L,K,NS)/HP(L)  
  RETURN
END SUBROUTINE MORPHJ