!!  Copyright (C) Stichting Deltares, 2005-2020.
!!
!!  This file is part of iMOD.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License as published by
!!  the Free Software Foundation, either version 3 of the License, or
!!  (at your option) any later version.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!!
!!  Contact: imod.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands.
!!
MODULE MOD_SCENTOOL_UTL

USE WINTERACTER
USE RESOURCE
USE MOD_DBL
USE MOD_IDFPLOT
USE MOD_IDF, ONLY : IDFREAD,IDFGETVAL,IDFIROWICOL
USE MOD_UTL, ONLY : ITOS,RTOS,UTL_PLOT1BITMAP,UTL_PLOT2BITMAP,MXMESSAGE,UTL_INVERSECOLOUR,UTL_IMODFILLMENU, &
                    UTL_IMODFILLMENU_DEAL,LISTNAME,JDATETOGDATE,GDATETOJDATE,UTL_WSELECTFILE,UTL_GETUNIT, &
                    UTL_JDATETOIDATE,UTL_IDATETOJDATE,UTL_CREATEDIR
USE MODPLOT, ONLY : MPW
USE MOD_GRAPH, ONLY : GRAPH_MAIN,GRAPH_INIT,GRAPH,GRAPH_ALLOCATE,GRAPHDIM,GRAPH_DEALLOCATE
USE MOD_SCENTOOL_PAR
USE MOD_OSD, ONLY : OSD_OPEN
USE MOD_PMANAGER_PAR
USE MOD_PMANAGER_UTL, ONLY : PMANAGER_STRESSES,PMANAGER_SYSTEMS,PMANAGER_SORTTOPIC

REAL(KIND=DP_KIND),PRIVATE,DIMENSION(:),ALLOCATABLE :: X,Y
INTEGER,PRIVATE,DIMENSION(:),ALLOCATABLE :: XYP

CONTAINS
 
 !###======================================================================
 SUBROUTINE ST_DRAWPNTS(IDD,IDG,IPOS,IACTION,ISYMBOL,ICLR,IMODE)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IDD,IDG,ISYMBOL,ICLR,IACTION,IMODE
 INTEGER,INTENT(IN),DIMENSION(:) :: IPOS
 TYPE(WIN_MESSAGE) :: MESSAGE
 INTEGER :: ITYPE,NROW,NCOL,IROW,ICOL,I,ICTYPE,NP,IP,JP,IMOVE
 REAL(KIND=DP_KIND) :: DX,DY,D,MIND,ISIZE,MOUSEX,MOUSEY,CHH,CHW

 ISIZE=1.0D0 !% of graphical units to be used for plotting markers
 
 !## imode  =0 wells
 !## imode  =1 observations
 
 !## iaction=1 add
 !## iaction=2 move
 !## iaction=3 delete
 
 !## determine maximum of points to be added to grid
 CALL WDIALOGSELECT(IDD)
 NROW=WINFOGRID(IDG,GRIDROWSCUR)
 NCOL=WINFOGRID(IDG,GRIDCOLUMNS)

 !## find first blanco line
 IF(IACTION.EQ.1)THEN
  DO IROW=1,NROW
   I=0
   DO ICOL=1,NCOL
    IF(WINFOGRIDCELL(IDG,ICOL,IROW,GRIDCELLDEFINED).EQ.0)I=I+1
   ENDDO
   !## find first empty row
   IF(I.EQ.NCOL)EXIT
  END DO
  IF(IROW.GT.NROW)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot insert more points!','Information')
   RETURN
  ENDIF
  CALL WCURSORSHAPE(ID_CURSORPOINTPLUS)
 ELSE
  CALL WCURSORSHAPE(ID_CURSORPOINT)
  ALLOCATE(X(NROW),Y(NROW),XYP(NROW))
  !## read grid for locations
  IF(.NOT.STGETPNTS(IDD,IDG,IPOS,NROW,NP))RETURN
 ENDIF

 CALL IGRPLOTMODE(MODECOPY)
 CALL WINDOWOUTSTATUSBAR(4,'Terminate with the right mouse-button!')

 IP=0
 JP=0
 IMOVE=0

 CALL UTL_PLOT1BITMAP()
 CALL UTL_SETTEXTSIZE(CHW,CHH,FCT=ISIZE*5.0D0,IMARKER=1)
 CALL DBL_WGRTEXTFONT(IFAMILY=0,TWIDTH=CHW,THEIGHT=CHH,ISTYLE=0)

 DO
  CALL WMESSAGE(ITYPE,MESSAGE)
  SELECT CASE (ITYPE)
   
   !## mouse-move
   CASE (MOUSEMOVE)

    MOUSEX=MESSAGE%GX+OFFSETX
    MOUSEY=MESSAGE%GY+OFFSETY

    CALL WINDOWSELECT(0)
    CALL WINDOWOUTSTATUSBAR(1,'X:'//TRIM(RTOS(MOUSEX,'F',3))//' m, Y:'// &
                                    TRIM(RTOS(MOUSEY,'F',3))//' m')
    
    !## move/delete actions
    IF(IACTION.EQ.2.OR.IACTION.EQ.3)THEN

     IF(IMOVE.EQ.0)THEN
      !## find nearest point
      MIND=(MPW%XMAX-MPW%XMIN)/100.0D0
      IP  = 0
      DO I=1,NP
       DX=(MOUSEX-X(I))**2.0D0
       DY=(MOUSEY-Y(I))**2.0D0
       D=0.0D0
       IF(DX+DY.GT.0.0D0)D=SQRT(DX+DY)
       IF(D.LT.MIND)THEN
        MIND=D
        IP  =I
       ENDIF
      END DO
      
      IF(IP.EQ.0)CALL WCURSORSHAPE(ID_CURSORPOINT)
      IF(IP.NE.0)THEN
       IF(IACTION.EQ.2)CALL WCURSORSHAPE(ID_CURSORMOVE)
       IF(IACTION.EQ.3)CALL WCURSORSHAPE(ID_CURSORPOINTMIN)
       IF(IP.NE.JP)THEN
        CALL WDIALOGSELECT(IDD)
        CALL WGRIDCOLOURROW(IDG,IP,RGBBACK=WRGB(200,0,0))
        IF(JP.NE.0)CALL WGRIDCOLOURROW(IDG,JP,RGBBACK=-1)
        JP=IP
       ENDIF
      ENDIF
     
     ELSE

      CALL UTL_PLOT1BITMAP()
      CALL IGRCOLOURN(UTL_INVERSECOLOUR(ICLR))
      CALL DBL_IGRMARKER(X(IP),Y(IP),ISYMBOL,IOFFSET=1)

      CALL WDIALOGSELECT(IDD)
      CALL WGRIDPUTCELLDOUBLE(IDG,IPOS(1),XYP(IP),MOUSEX)
      CALL WGRIDPUTCELLDOUBLE(IDG,IPOS(2),XYP(IP),MOUSEY)
      X(IP)=MOUSEX
      Y(IP)=MOUSEY

      CALL DBL_IGRMARKER(X(IP),Y(IP),ISYMBOL,IOFFSET=1)
      CALL UTL_PLOT2BITMAP()

     ENDIF
    ENDIF

   !## put point
   CASE (MOUSEBUTUP)
    IF(IACTION.NE.1)THEN
     CALL WDIALOGSELECT(IDD)
     IF(JP.NE.0)CALL WGRIDCOLOURROW(IDG,JP,RGBBACK=-1)
     JP=0
     IF(IMOVE.NE.0)CALL IDFPLOT(1)
    ENDIF
    IMOVE=0

   !## put point
   CASE (MOUSEBUTDOWN)
    SELECT CASE (MESSAGE%VALUE1)
     CASE (1)

      !## add point
      IF(IACTION.EQ.1)THEN
       CALL UTL_PLOT1BITMAP()
       CALL IGRCOLOURN(ICLR)
       CALL DBL_IGRMARKER(MOUSEX,MOUSEY,ISYMBOL,IOFFSET=1)
       CALL UTL_PLOT2BITMAP()

       CALL WDIALOGSELECT(IDD)
       DO ICOL=1,NCOL
        IF(ICOL.EQ.IPOS(1))THEN
         CALL WGRIDPUTCELLDOUBLE(IDG,IPOS(1),IROW,MOUSEX)
        ELSEIF(ICOL.EQ.IPOS(2))THEN
         CALL WGRIDPUTCELLDOUBLE(IDG,IPOS(2),IROW,MOUSEY)
        ELSE
         !## fill in default values
         ICTYPE=WINFOGRIDCELL(IDG,ICOL,IROW,GRIDCELLTYPE)
         SELECT CASE (ICTYPE)
          CASE (4)
           IF(IMODE.EQ.1)CALL WGRIDPUTCELLSTRING(IDG,ICOL,IROW,'Well '//TRIM(ITOS(IROW)))
           IF(IMODE.EQ.2)CALL WGRIDPUTCELLSTRING(IDG,ICOL,IROW,'Screen '//TRIM(ITOS(IROW)))
          CASE (5)
           CALL WGRIDPUTCELLINTEGER(IDG,ICOL,IROW,0)
          CASE (6)
           CALL WGRIDPUTCELLDOUBLE(IDG,ICOL,IROW,0.0D0)
         END SELECT
        ENDIF
       ENDDO
       IROW=IROW+1
       IF(IROW.GT.NROW)THEN
        CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot insert more points!','Information')
        EXIT
       ENDIF
      !## move
      ELSEIF(IACTION.EQ.2)THEN
       IMOVE=0
       IF(IP.NE.0)THEN
        IMOVE=IP
        CALL IGRPLOTMODE(MODEXOR)
        CALL WCURSORSHAPE(ID_NOCURSOR)
       ENDIF
      !## delete
      ELSEIF(IACTION.EQ.3)THEN
       IMOVE=0
       !## remove ip-number out of grid
       IF(IP.NE.0)THEN
        IMOVE=IP
        CALL WDIALOGSELECT(IDD)
        CALL WGRIDDELETEROWS(IDG,IP,NDEL=1,IREDUCE=DISABLED,ILABELS=ENABLED)
        CALL WCURSORSHAPE(ID_CURSORPOINT)
        CALL IDFPLOT(1)
        !## read grid for locations
        IF(.NOT.STGETPNTS(IDD,IDG,IPOS,NROW,NP))EXIT
       ENDIF
      ENDIF

     CASE (3)
      EXIT
    END SELECT

   !## bitmap scrolled, renew top-left pixel coordinates
   CASE (BITMAPSCROLLED)
    MPW%IX=MESSAGE%VALUE1
    MPW%IY=MESSAGE%VALUE2

  END SELECT
 END DO

 CALL WDIALOGSELECT(IDD)
 IF(JP.NE.0)CALL WGRIDCOLOURROW(IDG,JP,RGBBACK=-1)

 CALL WCURSORSHAPE(CURARROW)
 CALL WINDOWOUTSTATUSBAR(4,'')
! IF(IACTION.EQ.2)THEN
 IF(ALLOCATED(X))  DEALLOCATE(X)
 IF(ALLOCATED(Y))  DEALLOCATE(Y)
 IF(ALLOCATED(XYP))DEALLOCATE(XYP)
! ENDIF
 CALL IDFPLOT(1)

 END SUBROUTINE ST_DRAWPNTS

 !###======================================================================
 LOGICAL FUNCTION STGETPNTS(IDD,IDG,IPOS,N,NP)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IDD,IDG,N
 INTEGER,INTENT(IN),DIMENSION(2) :: IPOS
 INTEGER,INTENT(OUT) :: NP
 INTEGER :: I
  
 STGETPNTS=.FALSE.
 
 CALL WDIALOGSELECT(IDD)

 NP=0
 DO I=1,N
  IF(WINFOGRIDCELL(IDG,IPOS(1),I,GRIDCELLDEFINED).NE.0.AND. &
     WINFOGRIDCELL(IDG,IPOS(2),I,GRIDCELLDEFINED).NE.0)THEN
   NP=NP+1
   XYP(NP)=I
   CALL WGRIDGETCELLDOUBLE(IDF_GRID1,IPOS(1),I,X(NP))
   CALL WGRIDGETCELLDOUBLE(IDF_GRID1,IPOS(2),I,Y(NP))
  ENDIF
 ENDDO
 
 IF(NP.EQ.0)THEN
  DEALLOCATE(X,Y,XYP)
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Nothing to select (anymore).','Information')
  RETURN
 ENDIF

 STGETPNTS=.TRUE.
 
 END FUNCTION STGETPNTS
 
 !###======================================================================
 LOGICAL FUNCTION ST1CREATEIPF(NLAY,IU,TOP,BOT,L,KHV,Q,LAYQ,DIR)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NLAY
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER,INTENT(INOUT),DIMENSION(:) :: IU,LAYQ
 REAL(KIND=DP_KIND),INTENT(INOUT),DIMENSION(:) :: TOP,BOT,L,KHV,Q
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: TLP
 INTEGER :: I,J,K,IOS,ILAY,IROW,ICOL,JU,IDT
 REAL(KIND=DP_KIND) :: Z1,Z2,ZCOR,MEANQ,SUMQ
 CHARACTER(LEN=256) :: LINE
 CHARACTER(LEN=50) :: QID

 ST1CREATEIPF=.FALSE.

 CALL UTL_CREATEDIR(TRIM(DIR)//'\wells')

 IU=0

 !## open summary for well-strength
 IU(NLAY+1)=UTL_GETUNIT()
 CALL OSD_OPEN(IU(NLAY+1),FILE=TRIM(DIR)//'\wells\wells.ipf',STATUS='UNKNOWN',IOSTAT=IOS)
 IF(IOS.NE.0)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot create '//TRIM(DIR)//'\wells\wells.ipf','Error')
  RETURN
 ENDIF

 DO ILAY=1,NLAY
  IU(ILAY)=UTL_GETUNIT()
  CALL OSD_OPEN(IU(ILAY),FILE=TRIM(DIR)//'\wells\wells_l'//TRIM(ITOS(ILAY))//'.ipf',STATUS='UNKNOWN',IOSTAT=IOS)
  IF(IOS.NE.0)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot create '//TRIM(DIR)//'\wells\wells_l'// &
        TRIM(ITOS(ILAY))//'.ipf','Error')
   RETURN
  ENDIF
 ENDDO

 IF(.NOT.ST1OPENFILES(NLAY))RETURN
 
 !## everything opened, write/read information for wells
 LINE=TRIM(ITOS(SUM(WEL(1:NWEL)%NLOC)))
 WRITE(IU(NLAY+1),'(A)') TRIM(LINE)
 LINE=TRIM(ITOS(7+NLAY))
 WRITE(IU(NLAY+1),'(A)') TRIM(LINE)
 WRITE(IU(NLAY+1),'(A)') 'X'
 WRITE(IU(NLAY+1),'(A)') 'Y'
 WRITE(IU(NLAY+1),'(A)') 'Z1'
 WRITE(IU(NLAY+1),'(A)') 'Z2'
 WRITE(IU(NLAY+1),'(A)') 'Q-ID'
 WRITE(IU(NLAY+1),'(A)') 'MEAN_Q (M3/DAG)'
 WRITE(IU(NLAY+1),'(A)') 'SUM_Q (M3/SIMULATION)'
 DO ILAY=1,NLAY
  LINE='ILAY'//TRIM(ITOS(ILAY))
  WRITE(IU(NLAY+1),'(A)') TRIM(LINE)
 END DO
 WRITE(IU(NLAY+1),'(A)') '0,TXT'
 DO ILAY=1,NLAY
  LINE=TRIM(ITOS(SUM(WEL(1:NWEL)%NLOC)))
  WRITE(IU(ILAY),'(A)') TRIM(LINE)
  WRITE(IU(ILAY),'(A)') '6'
  WRITE(IU(ILAY),'(A)') 'X'
  WRITE(IU(ILAY),'(A)') 'Y'
  WRITE(IU(ILAY),'(A)') 'Q-ID'
  WRITE(IU(ILAY),'(A)') 'ILAY'
  WRITE(IU(ILAY),'(A)') 'Z1'
  WRITE(IU(ILAY),'(A)') 'Z2'
  WRITE(IU(ILAY),'(A)') '3,TXT'
 END DO

 !## number of well-systems
 DO I=1,NWEL

  !## allocate multiplication factors to be used to compute well-strengths
  ALLOCATE(TLP(WEL(I)%NLOC,NLAY))
  TLP=0.0D0

  !## each well inside a wel-system ... get top/bottom,permeabilities
  DO J=1,WEL(I)%NLOC

   !## get top/bottoms
   DO ILAY=1,NLAY
    TOP(ILAY)=TOPIDF(ILAY)%NODATA
    BOT(ILAY)=BOTIDF(ILAY)%NODATA
    CALL IDFIROWICOL(TOPIDF(ILAY),IROW,ICOL,WEL(I)%LOC(J)%X,WEL(I)%LOC(J)%Y)
    IF(IROW.NE.0.AND.ICOL.NE.0)TOP(ILAY)=IDFGETVAL(TOPIDF(ILAY),IROW,ICOL)
    CALL IDFIROWICOL(BOTIDF(ILAY),IROW,ICOL,WEL(I)%LOC(J)%X,WEL(I)%LOC(J)%Y)
    IF(IROW.NE.0.AND.ICOL.NE.0)BOT(ILAY)=IDFGETVAL(BOTIDF(ILAY),IROW,ICOL)
    !## kd averaging
    IF(WEL(I)%ITYPE.EQ.2)THEN
     KHV(ILAY)=KHVIDF(ILAY)%NODATA
     CALL IDFIROWICOL(KHVIDF(ILAY),IROW,ICOL,WEL(I)%LOC(J)%X,WEL(I)%LOC(J)%Y)
     IF(IROW.NE.0.AND.ICOL.NE.0)KHV(ILAY)=IDFGETVAL(KHVIDF(ILAY),IROW,ICOL)
     IF(IKD(ILAY).EQ.1)THEN
      IF(KHV(ILAY).NE.KHVIDF(ILAY)%NODATA.AND. &
         TOP(ILAY).NE.TOPIDF(ILAY)%NODATA.AND.&
         BOT(ILAY).NE.BOTIDF(ILAY)%NODATA)THEN
       KHV(ILAY)=KHV(ILAY)/(TOP(ILAY)-BOT(ILAY))
      ELSE
       KHV(ILAY)=KHVIDF(ILAY)%NODATA 
      ENDIF
     ENDIF
     KHV(ILAY)=MAX(0.0D0,KHV(ILAY))
    ENDIF
   ENDDO

   !## surfacelevel -> msl
   ZCOR=0.0D0; IF(WEL(I)%ILOCT.EQ.2)ZCOR=TOP(1)

   !## fit current position (compute length of well inside each modellayer)
   DO ILAY=1,NLAY
    Z1=0.0D0; Z2=0.0D0; L(ILAY)=0.0D0
    IF(TOP(ILAY).NE.TOPIDF(ILAY)%NODATA.AND.BOT(ILAY).NE.BOTIDF(ILAY)%NODATA)THEN
     Z1=MIN(TOP(ILAY),ZCOR+WEL(I)%LOC(J)%Z1)
     Z2=MAX(BOT(ILAY),ZCOR+WEL(I)%LOC(J)%Z2)
     L(ILAY)=MAX(0.0D0,Z1-Z2)
    ENDIF
   END DO
   
   CALL UTL_PCK_GETTLP(NLAY,TLP(J,:),KHV,TOP,BOT,Z1,Z2,0.1D0) 
   
   !## well within any aquifer(s)
   IF(SUM(L).GT.0.0D0)THEN
    !## compute percentage and include sumkd, only if itype.eq.2
    IF(WEL(I)%ITYPE.EQ.2)L=L*KHV
    TLP(J,:)=(1.0D0/SUM(L))*L(:)  !## percentage (0-1) L*KD
   ENDIF

  ENDDO

  IF(SUM(TLP).GT.0.0D0)THEN
   !## overall distribution factors, inluding L*KD
   TLP(:,:)=(1.0D0/SUM(TLP))*TLP(:,:)
  ENDIF

  !## write results
  DO J=1,WEL(I)%NLOC

   SUMQ=0.0D0
   LAYQ=0

   !## multiply well strength with appropriate factor
   DO ILAY=1,NLAY
    JU=UTL_GETUNIT()
    QID='well_sys'//TRIM(ITOS(I))//'_loc'//TRIM(ITOS(J))//'_l'//TRIM(ITOS(ILAY))
    CALL OSD_OPEN(JU,FILE=TRIM(DIR)//'\wells\'//TRIM(QID)//'.txt',STATUS='UNKNOWN',IOSTAT=IOS)
    IF(IOS.NE.0)THEN
     CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot create file: '//CHAR(13)// &
          TRIM(DIR)//'\wells\'//TRIM(QID)//'.txt','Error')
     RETURN
    ENDIF
    LINE=TRIM(ITOS(WEL(I)%NQ-1))  !## one less since last date is not connected to well strength
    WRITE(JU,'(A)') TRIM(LINE)
    WRITE(JU,'(A)') '2'
    WRITE(JU,'(A)') 'Date,-999'
    WRITE(JU,'(A)') 'Q(m3/d),-999'
    DO K=1,WEL(I)%NQ-1
     Q(ILAY)=TLP(J,ILAY)*WEL(I)%Q(K)%QRATE
     LINE=TRIM(ITOS(UTL_JDATETOIDATE(WEL(I)%Q(K)%IDATE)))//','//TRIM(RTOS(Q(ILAY),'F',2))
     WRITE(JU,'(A)') TRIM(LINE)
     IF(Q(ILAY).NE.0)THEN
      IDT=WEL(I)%Q(K+1)%IDATE-WEL(I)%Q(K)%IDATE
      SUMQ=SUMQ+Q(ILAY)*REAL(IDT) !## sumq for current system
      LAYQ(ILAY)=LAYQ(ILAY)+IDT   !## count for modellayer
     ENDIF
    ENDDO
    CLOSE(JU)

    LINE=TRIM(RTOS(WEL(I)%LOC(J)%X,'F',3))//','// &
         TRIM(RTOS(WEL(I)%LOC(J)%Y,'F',3))//','// &
         TRIM(QID)//','// &
         TRIM(ITOS(ILAY))//','// &
         TRIM(RTOS(WEL(I)%LOC(J)%Z1,'F',3))//','// &
         TRIM(RTOS(WEL(I)%LOC(J)%Z2,'F',3))
    WRITE(IU(ILAY),'(A)') TRIM(LINE)
   ENDDO

   MEANQ=SUMQ/REAL(SUM(LAYQ))
   LINE=TRIM(RTOS(WEL(I)%LOC(J)%X,'F',3))//','// &
        TRIM(RTOS(WEL(I)%LOC(J)%Y,'F',3))//','// &
        TRIM(RTOS(WEL(I)%LOC(J)%Z1,'F',3))//','// &
        TRIM(RTOS(WEL(I)%LOC(J)%Z2,'F',3))//','// &
        TRIM(QID)//','// &
        TRIM(RTOS(MEANQ,'G',9))//','// &
        TRIM(RTOS(SUMQ,'G',9))
   DO ILAY=1,NLAY; LINE=TRIM(LINE)//','//TRIM(ITOS(LAYQ(ILAY))); END DO
   WRITE(IU(NLAY+1),'(A)') TRIM(LINE)

  ENDDO
  DEALLOCATE(TLP)

 ENDDO

 ST1CREATEIPF=.TRUE.

 END FUNCTION ST1CREATEIPF

 !###======================================================================
 LOGICAL FUNCTION ST1ADDWELLSTOPRJ(DIR,NLAY)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NLAY
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER :: I,J,N,ITOPIC,IPER,ISYS,IYR,IDY,IMT,IMH,IHR,ISC,ISUBTOPIC,ILAY
 CHARACTER(LEN=MAXLENPRJ) :: CD

 ST1ADDWELLSTOPRJ=.FALSE.

 !## wells
 ITOPIC=TWEL

 !## store wells at earliest date --- and then add them to all coming as well
  
 !## add a new period
 !## add a new system for current period 
! IF(IPER.EQ.0.OR.ISYS.EQ.0)THEN
!  LNEW=.FALSE.; IF(IPER.EQ.0)LNEW=.TRUE.
 
 !## loop for simulation times and add them to the prj-files
 DO J=0,SIMNPER
  
  CD=TRIM(JDATETOGDATE(SIMJDATE(J),DTYPE=2))//'000000'
  CALL UTL_GDATE(SIMJDATE(J),IYR,IMH,IDY); IMT=0; IHR=0; ISC=0

  !## test whether date has been defined already
  IPER=0; N=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))N=SIZE(TOPICS(ITOPIC)%STRESS)
  DO I=1,N
   !## defined already
   IF(TRIM(UTL_CAP(TOPICS(ITOPIC)%STRESS(I)%CDATE,'U')).EQ.TRIM(UTL_CAP(CD,'U')))THEN; IPER=I; EXIT; ENDIF
  ENDDO

  DO ILAY=1,NLAY
 
   !## add new system
   ISYS=0

   !## create new period
   CALL PMANAGER_STRESSES(ITOPIC,IPER)   
   !## create new system
   CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS)

   TOPICS(ITOPIC)%STRESS(IPER)%CDATE=CD
   TOPICS(ITOPIC)%STRESS(IPER)%IYR=IYR; TOPICS(ITOPIC)%STRESS(IPER)%IMH=IMH
   TOPICS(ITOPIC)%STRESS(IPER)%IDY=IDY; TOPICS(ITOPIC)%STRESS(IPER)%IHR=IHR
   TOPICS(ITOPIC)%STRESS(IPER)%IMT=IMT; TOPICS(ITOPIC)%STRESS(IPER)%ISC=ISC

   DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS
    TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IACT =1
    TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME=TRIM(DIR)//'\wells\wells_l'//TRIM(ITOS(ILAY))//'.ipf'
    TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT  =1.0D0
    TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IMP  =0.0D0
    TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST=2
    TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST =-999.99D0
    TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY =ILAY
    TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS='wells_l'//TRIM(ITOS(ILAY))//'.ipf'
   ENDDO

  ENDDO
 
 ENDDO
 
 CALL PMANAGER_SORTTOPIC(ITOPIC,IPER)
 
 ST1ADDWELLSTOPRJ=.TRUE.

 END FUNCTION ST1ADDWELLSTOPRJ

 !###======================================================================
 LOGICAL FUNCTION ST1OPENFILES(NLAY)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NLAY
 INTEGER :: ILAY,ITOPIC
 LOGICAL :: LEX
 
 ST1OPENFILES=.FALSE.
 
 ALLOCATE(TOPIDF(NLAY),BOTIDF(NLAY),KHVIDF(NLAY))
 DO ILAY=1,NLAY; CALL IDFNULLIFY(TOPIDF(ILAY)); ENDDO
 DO ILAY=1,NLAY; CALL IDFNULLIFY(BOTIDF(ILAY)); ENDDO
 DO ILAY=1,NLAY; CALL IDFNULLIFY(KHVIDF(ILAY)); ENDDO
 ALLOCATE(IKD(NLAY)); IKD=0
  
 DO ILAY=1,NLAY
  !## top
  ITOPIC=2; LEX=.FALSE.
  IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
   IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
    IF(IDFREAD(TOPIDF(ILAY),TOPICS(ITOPIC)%STRESS(1)%FILES(1,ILAY)%FNAME,0))LEX=.TRUE.
   ENDIF
  ENDIF
  IF(.NOT.LEX)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot read TOP for model layer '//TRIM(ITOS(ILAY)),'Error')
   RETURN
  ENDIF
  !## bot
  ITOPIC=3; LEX=.FALSE.
  IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
   IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
    IF(IDFREAD(BOTIDF(ILAY),TOPICS(ITOPIC)%STRESS(1)%FILES(1,ILAY)%FNAME,0))LEX=.TRUE.
   ENDIF
  ENDIF
  IF(.NOT.LEX)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot read BOT for model layer '//TRIM(ITOS(ILAY)),'Error')
   RETURN
  ENDIF
  !## khv
  ITOPIC=7; LEX=.FALSE.
  IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
   IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
    IF(IDFREAD(KHVIDF(ILAY),TOPICS(ITOPIC)%STRESS(1)%FILES(1,ILAY)%FNAME,0))LEX=.TRUE.
   ENDIF
  ENDIF
  !## try kdw instead
  IF(.NOT.LEX)THEN
   ITOPIC=6; LEX=.FALSE.
   IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
    IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
     IF(IDFREAD(KHVIDF(ILAY),TOPICS(ITOPIC)%STRESS(1)%FILES(1,ILAY)%FNAME,0))LEX=.TRUE.
     IKD(ILAY)=1
    ENDIF
   ENDIF
   IF(.NOT.LEX)THEN
    CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot read KHV or KDW for model layer '//TRIM(ITOS(ILAY)),'Error')
    RETURN
   ENDIF
  ENDIF
 END DO

 ST1OPENFILES=.TRUE.
 
 END FUNCTION ST1OPENFILES
 
 !###======================================================================
 SUBROUTINE ST1CLOSEFILES(IU)
 !###======================================================================
 IMPLICIT NONE   
 INTEGER,INTENT(IN),DIMENSION(:),OPTIONAL :: IU
 INTEGER :: ILAY
 LOGICAL :: LEX
      
 DO ILAY=1,SIZE(TOPIDF)
  IF(TOPIDF(ILAY)%IU.GT.0)THEN
   INQUIRE(FILE=TOPIDF(ILAY)%FNAME,OPENED=LEX)
   IF(LEX)CLOSE(TOPIDF(ILAY)%IU)
   TOPIDF(ILAY)%IU=0
  ENDIF
 ENDDO
 DO ILAY=1,SIZE(BOTIDF)
  IF(BOTIDF(ILAY)%IU.GT.0)THEN
   INQUIRE(FILE=BOTIDF(ILAY)%FNAME,OPENED=LEX)
   IF(LEX)CLOSE(BOTIDF(ILAY)%IU)
   BOTIDF(ILAY)%IU=0
  ENDIF
 ENDDO
 DO ILAY=1,SIZE(KHVIDF)
  IF(KHVIDF(ILAY)%IU.GT.0)THEN
   INQUIRE(FILE=KHVIDF(ILAY)%FNAME,OPENED=LEX)
   IF(LEX)CLOSE(KHVIDF(ILAY)%IU)
   KHVIDF(ILAY)%IU=0
  ENDIF
 ENDDO
 
 IF(PRESENT(IU))THEN
  DO ILAY=1,SIZE(IU)
   IF(IU(ILAY).GT.0)THEN
    INQUIRE(IU(ILAY),OPENED=LEX)
    IF(LEX)CLOSE(IU(ILAY))
   ENDIF
  ENDDO
 ENDIF
 
 IF(ALLOCATED(IKD))DEALLOCATE(IKD)
 
 IF(ALLOCATED(TOPIDF))THEN
  CALL IDFDEALLOCATE(TOPIDF,SIZE(TOPIDF)); DEALLOCATE(TOPIDF)
 ENDIF
 IF(ALLOCATED(BOTIDF))THEN
  CALL IDFDEALLOCATE(BOTIDF,SIZE(BOTIDF)); DEALLOCATE(BOTIDF)
 ENDIF
 IF(ALLOCATED(KHVIDF))THEN
  CALL IDFDEALLOCATE(KHVIDF,SIZE(KHVIDF)); DEALLOCATE(KHVIDF)
 ENDIF

 END SUBROUTINE ST1CLOSEFILES
  
 !###======================================================================
 SUBROUTINE ST1SIMBOXWELLS(XMIN,YMIN,XMAX,YMAX)
 !###======================================================================
 IMPLICIT NONE
 REAL(KIND=DP_KIND),INTENT(INOUT) :: XMIN,YMIN,XMAX,YMAX
 INTEGER :: I,J

 DO I=1,NWEL
  DO J=1,WEL(I)%NLOC
   XMIN=MIN(XMIN,WEL(I)%LOC(J)%X)
   XMAX=MAX(XMAX,WEL(I)%LOC(J)%X)
   YMIN=MIN(YMIN,WEL(I)%LOC(J)%Y)
   YMAX=MAX(YMAX,WEL(I)%LOC(J)%Y)
  END DO
 END DO

 END SUBROUTINE ST1SIMBOXWELLS
 
 !###======================================================================
 INTEGER FUNCTION ST1ERROR(IOS,TEXT)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IOS
 CHARACTER(LEN=*),INTENT(IN) :: TEXT

 ST1ERROR=IOS
 IF(IOS.EQ.0)RETURN

 CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,TRIM(TEXT),'Error')

 END FUNCTION ST1ERROR

 !###======================================================================
 SUBROUTINE ST1_GETCOLOUR(IDD,IDF)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IDD,IDF
 INTEGER :: IRGB
 
 CALL WDIALOGSELECT(IDD)
 CALL WDIALOGGETINTEGER(IDF,IRGB)
 CALL WSELECTCOLOUR(IRGB)
 IF(WINFODIALOG(4).EQ.1)CALL WDIALOGPUTINTEGER(IDF,IRGB)
 CALL WDIALOGCOLOUR(IDF,IRGB,IRGB)
 
 END SUBROUTINE ST1_GETCOLOUR

 !###======================================================================
 SUBROUTINE ST_SYMBOLCOLOUR(IDD,IDC)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IDD,IDC
 INTEGER :: ICLR
 
 CALL WDIALOGSELECT(IDD)
 CALL WDIALOGGETINTEGER(IDC,ICLR)
 CALL WDIALOGCOLOUR(IDC,ICLR,ICLR)
 
 END SUBROUTINE ST_SYMBOLCOLOUR
 
 !###======================================================================
 SUBROUTINE ST_SYMBOLDRAW(IDD,IDF,IDM,IDC)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IDD,IDF,IDM,IDC
 INTEGER :: IMARKER
 
 CALL ST_SYMBOLCOLOUR(IDD,IDC)

 CALL WDIALOGSELECT(IDD)
 CALL WDIALOGGETMENU(IDM,IMARKER)
 
 CALL IGRPLOTMODE(MODECOPY)
 CALL IGRSELECT(DRAWFIELD,IDF)
 CALL IGRCOLOURN(WRGB(255,255,255))
 CALL IGRFILLPATTERN(SOLID)
 CALL DBL_IGRRECTANGLE(0.0D0,0.0D0,1.0D0,1.0D0)
 CALL IGRFILLPATTERN(OUTLINE)
 CALL IGRCOLOURN(WRGB(0,0,0))
 CALL DBL_IGRAREA(0.0D0,0.0D0,1.0D0,1.0D0)
 CALL DBL_IGRUNITS(0.0D0,0.0D0,1.0D0,1.0D0)

 CALL IGRLINETYPE(SOLIDLINE)
 CALL DBL_WGRTEXTFONT(IFAMILY=0,TWIDTH=0.5D0,THEIGHT=0.5D0,ISTYLE=0)
 CALL DBL_IGRMARKER(0.5D0,0.5D0,IMARKER)
  
 END SUBROUTINE ST_SYMBOLDRAW

 !###======================================================================
 SUBROUTINE ST1FILLRESULTS()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 !## get available folders in scenario project
 CALL WDIALOGSELECT(ID_DSCENTOOLTAB5)
 CALL UTL_IMODFILLMENU(IDF_MENU1,SCFFNAME(:INDEX(SCFFNAME,'.',.TRUE.)-1),'*','D',NRES,1,1)
 IF(NRES.GT.0)THEN
  DO I=1,NRES; RES(I)%CNAME=LISTNAME(I); ENDDO
  CALL UTL_IMODFILLMENU_DEAL()
 ENDIF
 
 END SUBROUTINE ST1FILLRESULTS

 !###======================================================================
 SUBROUTINE ST1FIELDS()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: ITAB

 CALL WDIALOGSELECT(ID_DSCENTOOL)
 CALL WDIALOGGETTAB(IDF_TAB,ITAB)
 SELECT CASE (ITAB)
  CASE (ID_DSCENTOOLTAB1)
   CALL ST1FIELDS_STATE(ITAB,NWEL)
  CASE (ID_DSCENTOOLTAB2)
   CALL ST1FIELDS_STATE(ITAB,NCUT)
  CASE (ID_DSCENTOOLTAB3)
   CALL ST1FIELDS_STATE(ITAB,NOBS)
  CASE (ID_DSCENTOOLTAB4)
   CALL ST1FIELDS_STATE(ITAB,NMON)
  CASE (ID_DSCENTOOLTAB5)
   CALL ST1FIELDS_STATE(ITAB,NRES)
 END SELECT

 !## no computation available without wells or cuttings
 ITAB=1
 IF((NWEL.EQ.0.AND.NCUT.EQ.0))ITAB=0 !.OR.LEN_TRIM(SCFFNAME).EQ.0)ITAB=0
 CALL WDIALOGSELECT(ID_DSCENTOOL)
 CALL WDIALOGTABSTATE(IDF_TAB,ID_DSCENTOOLTAB5,ITAB)

! CALL WDIALOGSELECT(ID_DSCENTOOLTAB5)
! CALL WDIALOGFIELDSTATE(IDF_MENU2,MIN(1,NRES))
! CALL WDIALOGFIELDSTATE(IDF_LABEL2,MIN(1,NRES))

 END SUBROUTINE ST1FIELDS

 !###======================================================================
 SUBROUTINE ST1FIELDS_STATE(ITAB,N)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ITAB,N
 INTEGER :: I,J

 CALL WDIALOGSELECT(ITAB)

 !## check number of active elements
 I=MAX(0,MIN(N,1))
 IF(I.GT.0)THEN
  IF(ITAB.EQ.ID_DSCENTOOLTAB5)THEN
   CALL WDIALOGGETMENU(IDF_MENU1,RES%IRES)
   I=MIN(1,SUM(RES(1:NRES)%IRES))
  ELSE
   CALL UTL_DEBUGLEVEL(0)
   CALL WDIALOGGETMENU(IDF_MENU1,I)
   CALL UTL_DEBUGLEVEL(1)
   I=MAX(0,MIN(1,I))
  ENDIF
 ENDIF
 CALL WDIALOGFIELDSTATE(ID_DELETE,I)
 IF(ITAB.EQ.ID_DSCENTOOLTAB5)THEN
  CALL WDIALOGFIELDSTATE(ID_MAP,I)
  J=I
  IF(J.EQ.1.AND.NOBS.EQ.0)J=0 
  CALL WDIALOGFIELDSTATE(ID_HISTOGRAM,J)
!  J=I
!  IF(J.EQ.1.AND.NMON.EQ.0)J=0
!  CALL WDIALOGFIELDSTATE(ID_PROFILE,J)
 ELSE
  CALL WDIALOGFIELDSTATE(ID_INFO,I)
  CALL WDIALOGFIELDSTATE(ID_SAVEAS,I)
 ENDIF
 
 END SUBROUTINE ST1FIELDS_STATE

 !###======================================================================
 SUBROUTINE ST1_PROPOPENSAVE(ICODE,ID,ITYPE)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ICODE,ID,ITYPE
 CHARACTER(LEN=256) :: FNAME,LINE
 CHARACTER(LEN=10) :: CDATE
 CHARACTER(LEN=30) :: LABEL
 INTEGER :: IU,IOS,I,IDATE
 REAL(KIND=DP_KIND) :: X,Y,Z1,Z2

 FNAME=SCFFNAME(:INDEX(SCFFNAME,'\',.TRUE.)-1)

 IF(ICODE.EQ.ID_OPEN)THEN        !## open
  IF(.NOT.UTL_WSELECTFILE('Comma-Separated File (*.csv)|*.csv|',&
       LOADDIALOG+PROMPTON+APPENDEXT,FNAME,'Open CSV File'))RETURN
 ELSE                            !## save/saveas
  IF(.NOT.UTL_WSELECTFILE('Comma-Separated File (*.csv)|*.csv|',&
       SAVEDIALOG+PROMPTON+APPENDEXT,FNAME,'Open CSV File'))RETURN
 ENDIF

 IU=UTL_GETUNIT()

 !## open
 IF(ICODE.EQ.ID_OPEN)THEN
  CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ,DENYWRITE',FORM='FORMATTED',IOSTAT=IOS)
 !## write
 ELSE 
  CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE,DENYREAD',FORM='FORMATTED',IOSTAT=IOS)
 ENDIF
 IF(ST1ERROR(IOS,'iMOD cannot open file '//TRIM(FNAME)).NE.0)RETURN

 CALL WDIALOGSELECT(ID)
 CALL WDIALOGUNDEFINED(DVALUE=NODATAGRID)

 SELECT CASE (ID)
  !## strength/measures
  CASE (ID_DSCENTOOL_PROPTAB1)

   !## date/duration switch
   CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1)
   IF(ICODE.EQ.ID_OPEN)THEN
    !## (empty) grid
    CALL WDIALOGCLEARFIELD(IDF_GRID1)
    !## read labels
    READ(IU,*,IOSTAT=IOS)
    !## read all data from csv file
    I=0
    DO
     READ(IU,*,IOSTAT=IOS) IDATE,X
     IF(IOS.NE.0)EXIT
     I=I+1
     IF(I.GT.NROWQ)THEN
      CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Current iMOD version cannot read more than '//TRIM(ITOS(NROWQ))// &
       ' lines'//CHAR(13)//'Current table will be filled in with max '//TRIM(ITOS(NROWQ))//' values','Error/warning')
      EXIT
     ENDIF
     CDATE=JDATETOGDATE(UTL_IDATETOJDATE(IDATE))
     CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,I,CDATE)
     IF(X.EQ.NODATAGRID)EXIT
     CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,3,I,X)
    ENDDO
    CALL ST1_PROPUPDATEGRID(ITYPE)
   ELSE
    !## (recompute) grid
    CALL ST1_PROPUPDATEGRID(ITYPE)
    !## write labels
    IF(ITYPE.EQ.1)WRITE(IU,'(A)') 'date[yyyymmdd],q[m/hr]'
    IF(ITYPE.EQ.2)WRITE(IU,'(A)') 'date[yyyymmdd],measure[m+nap]'
    !## write all data into csv file
    DO I=1,NROWQ
     CALL WGRIDGETCELLSTRING(IDF_GRID1,1,I,CDATE)
     IF(LEN_TRIM(CDATE).EQ.0)EXIT
     CALL WGRIDGETCELLDOUBLE(IDF_GRID1,3,I,X)
     IDATE=UTL_JDATETOIDATE(GDATETOJDATE(CDATE))
     LINE=TRIM(ITOS(IDATE))//','//TRIM(RTOS(X,'F',7))
     WRITE(IU,'(A)') TRIM(LINE)
    ENDDO
   ENDIF

  !## dimensions
  CASE (ID_DSCENTOOL_PROPTAB2)

   IF(ICODE.EQ.ID_OPEN)THEN
    !## (empty) grid
    CALL WDIALOGCLEARFIELD(IDF_GRID1)
    !## read labels
    READ(IU,*,IOSTAT=IOS)
    !## read all data from csv file
    I=0
    DO
     READ(IU,*,IOSTAT=IOS) LABEL,X,Y,Z1,Z2
     IF(IOS.NE.0)EXIT
     I=I+1
     IF(I.GT.NROWL)THEN
      CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Current iMOD version cannot read more than '//TRIM(ITOS(NROWL))// &
       ' lines'//CHAR(13)//'Current table will be filled in with max '//TRIM(ITOS(NROWL))//' values','Error/warning')
      EXIT
     ENDIF
     CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,I,LABEL)
     CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,2,I,X)
     CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,3,I,Y)
     CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,4,I,Z1)
     CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,5,I,Z2)
    ENDDO
    CALL IDFPLOT(1)

   ELSE
    !## write labels
    WRITE(IU,'(A)') 'label,z1,z2,x,y'
    !## write all data into csv file
    DO I=1,NROWL

     LABEL=''
     IF(WINFOGRIDCELL(IDF_GRID1,1,I,GRIDCELLDEFINED).EQ.1)CALL WGRIDGETCELLSTRING(IDF_GRID1,1,I,LABEL)

     Z1=NODATAGRID
     IF(WINFOGRIDCELL(IDF_GRID1,2,I,GRIDCELLDEFINED).EQ.1)CALL WGRIDGETCELLDOUBLE(IDF_GRID1,2,I,Z1)

     Z2=NODATAGRID
     IF(WINFOGRIDCELL(IDF_GRID1,3,I,GRIDCELLDEFINED).EQ.1)CALL WGRIDGETCELLDOUBLE(IDF_GRID1,3,I,Z2)

     IF(WINFOGRIDCELL(IDF_GRID1,4,I,GRIDCELLDEFINED).EQ.0)EXIT
     CALL WGRIDGETCELLDOUBLE(IDF_GRID1,4,I,X); IF(X.EQ.NODATAGRID)EXIT

     IF(WINFOGRIDCELL(IDF_GRID1,5,I,GRIDCELLDEFINED).EQ.0)EXIT
     CALL WGRIDGETCELLDOUBLE(IDF_GRID1,5,I,Y); IF(Y.EQ.NODATAGRID)EXIT

     LINE='"'//TRIM(LABEL)//'",'//TRIM(RTOS(Z1,'F',3))//','//TRIM(RTOS(Z2,'F',3))//','// &
                                  TRIM(RTOS(X,'F',3)) //','//TRIM(RTOS(Y,'F',3))
     WRITE(IU,'(A)') TRIM(LINE)

    ENDDO
   ENDIF

 END SELECT

 CLOSE(IU)

 END SUBROUTINE ST1_PROPOPENSAVE

 !###======================================================================
 SUBROUTINE ST1_PROPUPDATEGRID(ITYPE)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ITYPE
 INTEGER :: I,J,K,ITIME
 REAL(KIND=DP_KIND) :: DELT,Q
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: XLIST,JDATE
 CHARACTER(LEN=10) :: CDATE

 CALL WDIALOGSELECT(ID_DSCENTOOL_PROPTAB1)
 CALL WDIALOGUNDEFINED(DVALUE=NODATAGRID)
 CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,ITIME)

 !## if duration .. compute dates
 IF(ITIME.EQ.2)THEN

  !## initialize date in grid
  CALL WDIALOGGETSTRING(IDF_STRING2,CDATE)
  J=GDATETOJDATE(CDATE)  !## correct cdate whenever it exceeds possible dates!!!!

  CALL WDIALOGPUTSTRING(IDF_STRING2,CDATE)
  CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,1,CDATE)

  DO I=1,NROWQ-1
   IF(WINFOGRIDCELL(IDF_GRID1,2,I,GRIDCELLDEFINED).EQ.1)THEN
    CALL WGRIDGETCELLDOUBLE(IDF_GRID1,2,I,DELT)
    IF(DELT.LE.0.0D0)EXIT
    J=J+INT(DELT)
    CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,I+1,JDATETOGDATE(J))
   ELSE
    EXIT
   ENDIF
  END DO

 ENDIF

 !## compute all julian dates
 DO I=1,NROWQ
  IF(WINFOGRIDCELL(IDF_GRID1,1,I,GRIDCELLDEFINED).EQ.1)THEN
   CALL WGRIDGETCELLSTRING(IDF_GRID1,1,I,CDATE)
   IF(LEN_TRIM(CDATE).EQ.0)EXIT
   J=GDATETOJDATE(CDATE)  !## correct cdate whenever it exceeds possible dates!!!!
   CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,I,CDATE)
   CALL WGRIDPUTCELLINTEGER(IDF_GRID1,4,I,J)
  ELSE
   EXIT
  ENDIF
 ENDDO
 
 !## clear the rest
 DO J=I,NROWQ
  DO K=1,4; CALL WGRIDCLEARCELL(IDF_GRID1,K,J); END DO
 END DO

 !## read and sort data
 I=I-1; ALLOCATE(JDATE(I),XLIST(I)); XLIST=0.0D0
 DO J=1,I
  CALL WGRIDGETCELLINTEGER(IDF_GRID1,4,J,K); JDATE(J)=REAL(K,8)
  IF(WINFOGRIDCELL(IDF_GRID1,3,J,GRIDCELLDEFINED).EQ.1)CALL WGRIDGETCELLDOUBLE(IDF_GRID1,3,J,XLIST(J))
 ENDDO
 CALL QKSORT(I,JDATE,V2=XLIST) 
 DO J=1,I
  CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,J,JDATETOGDATE(INT(JDATE(J))))
  IF(XLIST(J).NE.NODATAGRID)CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,3,J,XLIST(J),'(F15.3)')
 ENDDO
 DEALLOCATE(JDATE,XLIST)
  
 !## computes length in between
 CALL WGRIDGETCELLINTEGER(IDF_GRID1,4,1,J)
 DO I=2,NROWQ-1
  IF(WINFOGRIDCELL(IDF_GRID1,1,I,GRIDCELLDEFINED).EQ.1)THEN
   CALL WGRIDGETCELLINTEGER(IDF_GRID1,4,I,K)
   IF(K.LE.0)EXIT
   DELT=REAL(K-J)
   CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,2,I-1,DELT)
   J=K
   IF(ITYPE.EQ.1)THEN
    !## initialise extraction rate
    IF(WINFOGRIDCELL(IDF_GRID1,3,I,GRIDCELLDEFINED).EQ.1)THEN
     CALL WGRIDGETCELLDOUBLE(IDF_GRID1,3,I-1,Q)
     IF(Q.EQ.NODATAGRID)CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,3,I-1,0.0D0,'(F15.3)')
    ELSE
     CALL WGRIDPUTCELLDOUBLE(IDF_GRID1,3,I-1,0.0D0,'(F15.3)')
    ENDIF
   ENDIF
  ELSE
   EXIT
  ENDIF
 END DO

 END SUBROUTINE ST1_PROPUPDATEGRID

!###======================================================================
 SUBROUTINE ST1_PROPFIELDS()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: J,K,ITIME
 INTEGER,DIMENSION(0:1) :: ICOLOR

 ICOLOR(0)=WRGB(255,0,0)
 ICOLOR(1)=-1

 CALL WDIALOGSELECT(ID_DSCENTOOL_PROPTAB1)
 CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,ITIME)
 !## input in dates
 IF(ITIME.EQ.1)THEN
  J=1
  K=0
 !## input in durations
 ELSE
  J=0
  K=1
 ENDIF

 CALL WDIALOGFIELDSTATE(IDF_STRING2,K)

 CALL WGRIDSTATE(IDF_GRID1,1,J)
 CALL WGRIDSTATE(IDF_GRID1,2,K)
 CALL WGRIDCOLOURCOLUMN(IDF_GRID1,1,-1,ICOLOR(J))
 CALL WGRIDCOLOURCOLUMN(IDF_GRID1,2,-1,ICOLOR(K))

 END SUBROUTINE ST1_PROPFIELDS

 !###======================================================================
 SUBROUTINE ST1_PROPGRAPH(ITYPE)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ITYPE !## 1=histogram 2=connected lines
 INTEGER :: I,NP,IDATE,ITYPE2,IEXIT
 TYPE(WIN_MESSAGE) :: MESSAGE2

 !## update grid ...
 CALL ST1_PROPUPDATEGRID(ITYPE)

 CALL GRAPH_ALLOCATE(1,1)
 ALLOCATE(GRAPH(1,1)%RX(NROWQ))
 ALLOCATE(GRAPH(1,1)%RY(NROWQ))

 GRAPH(1,1)%RX=0.0D0
 GRAPH(1,1)%RY=0.0D0
 NP=0
 DO I=1,NROWQ
  IF(WINFOGRIDCELL(IDF_GRID1,4,I,GRIDCELLDEFINED).EQ.1)THEN
   NP=NP+1
   !## date
   CALL WGRIDGETCELLINTEGER(IDF_GRID1,4,I,IDATE)
   GRAPH(1,1)%RX(NP)=REAL(IDATE)
  ELSE
   EXIT
  ENDIF
  IF(WINFOGRIDCELL(IDF_GRID1,3,I,GRIDCELLDEFINED).EQ.1)THEN
   !## z-value (measure-q3/hr)
   CALL WGRIDGETCELLDOUBLE(IDF_GRID1,3,I,GRAPH(1,1)%RY(NP))
  ENDIF
 END DO
 IF(NP.LE.1)THEN
  CALL GRAPH_DEALLOCATE()
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Nothing to draw!','Information')
  RETURN
 ENDIF
 !## make sure last is equal to final-least
 GRAPH(1,1)%RY(NP)=GRAPH(1,1)%RY(NP-1)
 GRAPH(1,1)%NP=NP
 IF(ITYPE.EQ.2)THEN
  GRAPH(1,1)%NP=GRAPH(1,1)%NP-1
 ENDIF
 GRAPH(1,1)%ICLR=WRGB(56,180,176)
!DO I=1,NP
!WRITE(*,*) I,GRAPH(1,1)%RX(I),GRAPH(1,1)%RY(I)
!END DO

 CALL WDIALOGGETSTRING(IDF_STRING1,GRAPH(1,1)%LEGTXT)
 
 GRAPH(1,1)%GTYPE=ITYPE
 GRAPHDIM(1)%IFIXX=0; GRAPHDIM(1)%IFIXY=0
 GRAPHDIM(1)%XTITLE='Date'
 GRAPHDIM(1)%LDATE=.TRUE.
 GRAPHDIM(1)%TEXTSIZE=5.0D0
 IF(ITYPE.EQ.1)THEN
  GRAPHDIM(1)%YTITLE='Q-Rate (m3/hr)'
  GRAPHDIM(1)%GRAPHNAMES='Q-Rate (m3/hr)'
 ELSEIF(ITYPE.EQ.2)THEN
  GRAPHDIM(1)%YTITLE='Measure (m)'
  GRAPHDIM(1)%GRAPHNAMES='Measure (m)'
 ENDIF
 GRAPHDIM(1)%IGROUP=1
 CALL GRAPH_INIT(3)
 DO 
  CALL WMESSAGE(ITYPE2,MESSAGE2)
  CALL GRAPH_MAIN(ITYPE2,MESSAGE2,IEXIT=IEXIT)
  IF(IEXIT.EQ.1)EXIT
 ENDDO
 CALL GRAPH_DEALLOCATE()

 END SUBROUTINE ST1_PROPGRAPH

 !###======================================================================
 SUBROUTINE ST1CLOSE(IQUESTION)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IQUESTION

 IDIAGERROR=1

 !## save scenario?
 IF(IQUESTION.EQ.1)THEN
  CALL WMESSAGEBOX(YESNOCANCEL,QUESTIONICON,COMMONNO,'Are you sure to stop the Scenario Tool without saving first ?','Question')
  IF(WINFODIALOG(4).NE.1)RETURN  !## cancel
! IF(WINFODIALOG(4).EQ.1)THEN
!  IF(.NOT.ST1SAVELOAD(ID_SAVEAS))RETURN  !## yes, do save and quit if Successfull
 ENDIF

 CALL ST1DEALLOCATE()

 CALL WINDOWSELECT(0)
 CALL WMENUSETSTATE(ID_SCENTOOL,2,0)

 CALL WDIALOGSELECT(ID_DSCENTOOL)
 CALL WDIALOGUNLOAD()
 CALL WDIALOGSELECT(ID_DSCENTOOL_PROP)
 CALL WDIALOGUNLOAD()

 !## refresh window
 CALL IDFPLOTFAST(0)

 IDIAGERROR=0

 END SUBROUTINE ST1CLOSE

 !###======================================================================
 SUBROUTINE PT_UTL_ALLOCATEWEL()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I
 
 CALL PT_UTL_DEALLOCATEWEL()
 ALLOCATE(WEL(MAXNWEL))

 !## nullify objects
 DO I=1,SIZE(WEL)
  NULLIFY(WEL(I)%LOC)
  NULLIFY(WEL(I)%Q)
  WEL(I)%NLOC=0
  WEL(I)%NQ  =0
 END DO

 NWEL=0; IWEL=0

 END SUBROUTINE PT_UTL_ALLOCATEWEL

 !###======================================================================
 SUBROUTINE PT_UTL_ALLOCATECUT()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 CALL PT_UTL_DEALLOCATECUT()
 ALLOCATE(CUT(MAXNCUT))

 DO I=1,SIZE(CUT)
  NULLIFY(CUT(I)%XY)
  CUT(I)%NXY=0
 END DO

 NCUT=0; ICUT=0

 END SUBROUTINE PT_UTL_ALLOCATECUT

 !###======================================================================
 SUBROUTINE PT_UTL_ALLOCATEOBS()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 CALL PT_UTL_DEALLOCATEOBS()
 ALLOCATE(OBS(MAXNOBS))

 DO I=1,SIZE(OBS)
  NULLIFY(OBS(I)%LOC)
  NULLIFY(OBS(I)%Z)
  OBS(I)%NLOC=0
  OBS(I)%NZ=0
 END DO

 NOBS=0; IOBS=0

 END SUBROUTINE PT_UTL_ALLOCATEOBS

 !###======================================================================
 SUBROUTINE PT_UTL_ALLOCATEMON()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 CALL PT_UTL_DEALLOCATEMON()
 ALLOCATE(MON(MAXNMON))

 DO I=1,SIZE(MON)
  NULLIFY(MON(I)%XY)
  NULLIFY(MON(I)%XZ)
  MON(I)%NXY=0
  MON(I)%NXZ=0
 END DO

 NMON=0; IMON=0

 END SUBROUTINE PT_UTL_ALLOCATEMON

 !###======================================================================
 SUBROUTINE PT_UTL_ALLOCATERES()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 CALL PT_UTL_DEALLOCATERES()
 ALLOCATE(RES(MAXNRES))

 DO I=1,SIZE(RES)
!  NULLIFY(RES(I)%IDFNAME)
  RES(I)%IRES  =0
!  RES(I)%NFILES=0
 END DO

 NRES=0

 END SUBROUTINE PT_UTL_ALLOCATERES

 !###======================================================================
 SUBROUTINE ST1DEALLOCATE()
 !###======================================================================
 IMPLICIT NONE

 IF(ALLOCATED(CONF))DEALLOCATE(CONF)
 CALL PT_UTL_DEALLOCATEWEL()
 CALL PT_UTL_DEALLOCATECUT()
 CALL PT_UTL_DEALLOCATEOBS()
 CALL PT_UTL_DEALLOCATEMON()
 CALL PT_UTL_DEALLOCATERES()

 CALL UTL_CLOSEUNITS()

 END SUBROUTINE ST1DEALLOCATE

 !###======================================================================
 SUBROUTINE PT_UTL_DEALLOCATEWEL()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 !## deallocate memory
 IF(ALLOCATED(WEL))THEN
  DO I=1,SIZE(WEL)
   IF(ASSOCIATED(WEL(I)%LOC))DEALLOCATE(WEL(I)%LOC)
   IF(ASSOCIATED(WEL(I)%Q))  DEALLOCATE(WEL(I)%Q)
  END DO
  DEALLOCATE(WEL)
 ENDIF

 NWEL=0; IWEL=0

 END SUBROUTINE PT_UTL_DEALLOCATEWEL

 !###======================================================================
 SUBROUTINE PT_UTL_DEALLOCATECUT()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 IF(ALLOCATED(CUT))THEN
  DO I=1,SIZE(CUT)
   IF(ASSOCIATED(CUT(I)%XY))DEALLOCATE(CUT(I)%XY)
  END DO
  DEALLOCATE(CUT)
 ENDIF

 NCUT=0; ICUT=0

 END SUBROUTINE PT_UTL_DEALLOCATECUT

 !###======================================================================
 SUBROUTINE PT_UTL_DEALLOCATEOBS()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 IF(ALLOCATED(OBS))THEN
  DO I=1,SIZE(OBS)
   IF(ASSOCIATED(OBS(I)%LOC))DEALLOCATE(OBS(I)%LOC)
   IF(ASSOCIATED(OBS(I)%Z))  DEALLOCATE(OBS(I)%Z)
  END DO
  DEALLOCATE(OBS)
 ENDIF

 NOBS=0; IOBS=0

 END SUBROUTINE PT_UTL_DEALLOCATEOBS

 !###======================================================================
 SUBROUTINE PT_UTL_DEALLOCATEMON()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I

 IF(ALLOCATED(MON))THEN
  DO I=1,SIZE(MON)
   IF(ASSOCIATED(MON(I)%XY))DEALLOCATE(MON(I)%XY)
   IF(ASSOCIATED(MON(I)%XZ))DEALLOCATE(MON(I)%XZ)
  END DO
  DEALLOCATE(MON)
 ENDIF

 NMON=0; IMON=0

 END SUBROUTINE PT_UTL_DEALLOCATEMON

 !###======================================================================
 SUBROUTINE PT_UTL_DEALLOCATERES()
 !###======================================================================
 IMPLICIT NONE
! INTEGER :: I

 IF(ALLOCATED(RES))THEN
!  DO I=1,SIZE(RES)
!   IF(ASSOCIATED(RES(I)%IDFNAME))DEALLOCATE(RES(I)%IDFNAME)
!  END DO
  DEALLOCATE(RES)
 ENDIF

 NRES=0

 END SUBROUTINE PT_UTL_DEALLOCATERES
 
END MODULE MOD_SCENTOOL_UTL