!!  Copyright (C) Stichting Deltares, 2005-2016.
!!
!!  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_IR

USE WINTERACTER
USE RESOURCE
USE MOD_IDF, ONLY : IDFREAD,IDFDEALLOCATE,IDFDEALLOCATEX
USE MOD_IDF_PAR, ONLY : IDFOBJ
USE IMODVAR, ONLY : IDIAGERROR
USE MODPLOT, ONLY : MPW
USE MOD_PREF_PAR, ONLY : PREFVAL
USE MOD_PREF, ONLY : PREFMAIN
USE MOD_UTL, ONLY : ITOS,RTOS,UTL_GETUNIT,INVERSECOLOUR,UTL_CAP,UTL_CLOSEUNITS,UTL_MESSAGEHANDLE,UTL_IDFSNAPTOGRID,UTL_WAITMESSAGE,&
                    UTL_DEL1TREE,UTL_CREATEDIR,UTL_READINITFILE,UTL_INSIDEPOLYGON
USE MOD_POLYGON_PAR
USE MOD_POLYGON_UTL, ONLY : POLYGON1INIT,POLYGON1CLOSE,POLYGON1FIELDS
USE MOD_POLYGON, ONLY : POLYGON1MAIN
USE MOD_POLYGON_DRAW, ONLY : POLYGON1DRAWSHAPE,POLYGON1PLOTYSEL
USE MOD_IR_PAR
USE MOD_IR_UTL
USE MOD_IR_FIELDS
USE MOD_IR_CLC, ONLY : IR1COMPUTEIR,IR2COUNTIMP,IR21DEALLOCATE,IR2DEALLOCATE
USE MOD_IR_SELECTEDCELLS, ONLY : IR_SELECTEDCELLS
USE MOD_IR_TARGETS, ONLY : IR1TARGETS
USE MOD_IR_MEASURES, ONLY : IR1MEASURES
USE MOD_IR_INVERSE, ONLY : IR1INVERSE
USE MOD_IR_GEN, ONLY : IR1GENCOPY,IR1GENDRAW,IR1GENREAD,IDV,MAXDV
USE MOD_IR_QPF, ONLY : IR1PRJFILES
USE MOD_IR_QUARTER, ONLY : IR1QUARTER_MAIN
USE MOD_IR_LINEAR, ONLY : IR1LINEAR_VIEWOUTPUT
USE MOD_START, ONLY : START_MAIN
USE MOD_LEGPLOT, ONLY : LEGPLOT_MAIN
USE MOD_OSD, ONLY : OSD_OPEN

CONTAINS

 !###======================================================================
 LOGICAL FUNCTION IR1NEW(ID,ICANCEL)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ID,ICANCEL
 INTEGER :: ITYPE,IC,IOPT
 INTEGER,DIMENSION(3) :: IFLD
 TYPE(WIN_MESSAGE) :: MESSAGE
 CHARACTER(LEN=MAXLEN) :: CNAME

 IR1NEW=.FALSE.

 CALL WDIALOGLOAD(ID_DIRADD,ID_DIRADD)

 SELECT CASE (ID)
  !## target
  CASE (ID_NEWTARGET)
   CALL WDIALOGTITLE('Define New Target')
   CALL WDIALOGPUTIMAGE(IDF_PICTURE1,ID_ICONIRTARGETBIG,1)
   IC  =1
   IFLD=3
   CALL WDIALOGPUTSTRING(IDF_GROUP1,'Define New Target')
   CALL WDIALOGPUTSTRING(IDF_LABEL1,'Nog in te vullen')
   CALL WDIALOGPUTSTRING(IDF_LABEL1,'A target defines the desired effect in a specified area. The Quick Scan tool uses the '// &
      'target as a benchmark for measures defined by the user. In addition, the user can let the Quick Scan tool select an '//&
      'optimal set op measures that satisfies the defined target.')

   CALL WDIALOGPUTSTRING(IDF_STRING1,'')
   CALL WDIALOGSETFIELD(IDF_STRING1)
  !## measure
  CASE (ID_NEWMEASURE)
   CALL WDIALOGTITLE('Define New Measure')
   CALL WDIALOGPUTIMAGE(IDF_PICTURE1,ID_ICONIRMEASUREBIG,1)
   IC  =2
   IFLD=3
   CALL WDIALOGPUTSTRING(IDF_GROUP1,'Define New Measure')
   CALL WDIALOGPUTSTRING(IDF_LABEL1,'Nog in te vullen')
   CALL WDIALOGPUTSTRING(IDF_LABEL1,'A measure defines a set of interventions in the hydrological system. The user has to '//&
      'define areas where measures need to be taken and select measures from a predefined list.')
   CALL WDIALOGPUTSTRING(IDF_STRING1,'')
   CALL WDIALOGSETFIELD(IDF_STRING1)
  !## results
  CASE (ID_NEWRESULTS)
   CALL WDIALOGTITLE('Define New Result')
   CALL WDIALOGPUTIMAGE(IDF_PICTURE1,ID_ICONIRRESULTBIG,1)
   IC  =3
   IFLD=1
   CALL WDIALOGPUTSTRING(IDF_RADIO1,'Compute Results by IR')
   CALL WDIALOGPUTSTRING(IDF_RADIO2,'Compute Results by Quartal Model')
   CALL WDIALOGPUTSTRING(IDF_RADIO3,'Compute Results by Entire Model')
   CALL WDIALOGFIELDSTATE(IDF_GROUP1,3)
!   CALL WDIALOGPUTSTRING(IDF_LABEL1,'')!Nog in te vullen')
   CALL WDIALOGPUTSTRING(IDF_LABEL1,'Chooce one of the options above to select the methodology to be used to compute '// &
                                    'results for the selected set of measures.')
   CALL WDIALOGFIELDSTATE(IDF_STRING1,3)
   CALL WDIALOGFIELDSTATE(IDF_LABEL3,3)
   CALL WDIALOGSETFIELD(IDOK)
 END SELECT

 CALL WDIALOGFIELDSTATE(IDF_RADIO1,IFLD(1))
 CALL WDIALOGFIELDSTATE(IDF_RADIO2,IFLD(2))
 CALL WDIALOGFIELDSTATE(IDF_RADIO3,IFLD(3))

 CALL WDIALOGFIELDSTATE(IDCANCEL,ICANCEL)

 CALL WDIALOGSHOW(-1,-1,0,3)

 DO
  CALL WMESSAGE(ITYPE,MESSAGE)
  CALL WDIALOGSELECT(MESSAGE%WIN)
  SELECT CASE (ITYPE)

   CASE (FIELDCHANGED)
    SELECT CASE (MESSAGE%VALUE1)
    END SELECT

   CASE (PUSHBUTTON)
    SELECT CASE (MESSAGE%VALUE1)

     CASE (IDOK)
      IF(IC.EQ.3)THEN
       IOPT=0
       CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,IOPT)
       IF(IOPT.EQ.1)CNAME='QuickScan'
       IF(IOPT.EQ.2)CNAME='Quarter'
       IF(IOPT.EQ.3)CNAME='Basis'
       IF(IR1CHECKCNAME(IC,CNAME))EXIT
      ELSE
       CALL WDIALOGGETSTRING(IDF_STRING1,CNAME)
       IF(LEN_TRIM(CNAME).EQ.0)THEN
        CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should specify a name','Error')
       ELSE
!        IF(IC.EQ.1)CNAME='[T]'//TRIM(CNAME)
!        IF(IC.EQ.2)CNAME='[M]'//TRIM(CNAME)
        IF(IR1CHECKCNAME(IC,CNAME))EXIT
       ENDIF
      ENDIF
     CASE (IDCANCEL)
      EXIT

    END SELECT

  END SELECT

 ENDDO

 CALL WDIALOGSELECT(ID_DIRADD)
 CALL WDIALOGUNLOAD()

 IF(MESSAGE%VALUE1.EQ.IDOK)THEN

  CALL IR1TREEFIELD(IC,CNAME)

  SELECT CASE (ID)
   CASE (ID_NEWTARGET)
    CALL POLYGON1FIELDS(ID_DIR_PMTAB1TAB2)
    CALL IR1FIELDS_TAB1()

   !## set measures
   CASE (ID_NEWMEASURE)
    CALL POLYGON1FIELDS(ID_DIR_PMTAB2TAB2)
    CALL IR1FIELDS_TAB2()

   !## compute results
   CASE (ID_NEWRESULTS)
    SELECT CASE (IOPT)
     !## ir consultation
     CASE (1)
      CALL IR1COMPUTEIR(.FALSE.,.FALSE.)
      CALL IR2DEALLOCATE()
      CALL IR21DEALLOCATE()

     !## quartal model
     CASE (2)
      IF(.NOT.IR1QUARTER_MAIN(2))THEN
       CALL UTL_MESSAGEHANDLE(1)
      ENDIF

     !## daily model
     CASE (3)
      IF(.NOT.IR1QUARTER_MAIN(3))THEN
       CALL UTL_MESSAGEHANDLE(1)
      ENDIF

    END SELECT
    CALL WDIALOGSELECT(ID_DIR_PMTAB3)
    CALL WDIALOGSETTAB(IDF_TAB1,ID_DIR_PMTAB3TAB1)
    CALL IR1FIELDS_TAB3TAB1()

  END SELECT

  IR1NEW=.TRUE.

 ENDIF

 CALL WDIALOGSELECT(ID_DIR_PM)

! IR1NEW=.TRUE.

 END FUNCTION IR1NEW

 !###======================================================================
 LOGICAL FUNCTION IR1CHECKCNAME(IC,CNAME)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: CNAME
 INTEGER,INTENT(IN) :: IC
 INTEGER :: J,N,ITREE,IFIELD,ID,ID1,TIR,JFIELD
 CHARACTER(LEN=MAXLEN),DIMENSION(3) :: CTREE
 CHARACTER(LEN=256) :: DIRNAME

! IR1CHECKCNAME=.true.
! return

 IR1CHECKCNAME=.FALSE.

 !## get current tree view position
 CALL IR1GETTREEVIEWID(ITREE,IFIELD)
 !## targets
 IF(IC.EQ.1)THEN
  !## check all the names
  N=NTARGET
  DO JFIELD=1,N
   IF(TRIM(UTL_CAP(TTREE(JFIELD)%CNAME,'U')).EQ.TRIM(UTL_CAP(CNAME,'U')))EXIT
  END DO
 !## measures
 ELSEIF(IC.EQ.2)THEN
  !## get current "mother"
  ID=TTREE(IFIELD)%TARGET_ID
  !## check all the names that belong to the same "mother"
  N=NMEASURE
  DO JFIELD=1,N
   IF(MTREE(JFIELD)%IDPOS.EQ.ID)THEN
    IF(TRIM(UTL_CAP(MTREE(JFIELD)%CNAME,'U')).EQ.TRIM(UTL_CAP(CNAME,'U')))EXIT
   ENDIF
  END DO
 !## results
 ELSEIF(IC.EQ.3)THEN
  !## get current "mother"
  ID=MTREE(IFIELD)%MEASURE_ID
  !## check all the names that belong to the same "mother"
  N  =NRESULT
  ID1=0
  DO JFIELD=1,N
   IF(RTREE(JFIELD)%IDPOS.EQ.ID)THEN
    IF(TRIM(UTL_CAP(RTREE(JFIELD)%CNAME,'U')).EQ.TRIM(UTL_CAP(CNAME,'U')))THEN
     ID1=RTREE(JFIELD)%RESULT_ID
     EXIT
    ENDIF
   ENDIF
  END DO
!  IF(ID1.EQ.0)PAUSE
 ENDIF

 !## check whether there are polygons given that yield a result anyhow
 IF(IC.EQ.3)THEN
  !## copy data of current measures
  CALL IR1SHAPE2POL(ITREE,IFIELD)
  !## restore them again ...
  CALL IR1POL2SHAPE(ITREE,IFIELD)
  !## are there existing polygons?
  IF(MTREE(IFIELD)%NPOL.EQ.0)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should define some target or measure polygons first','Error')
  ELSE
   !## impulses are active within current polygons (all!)
   DO J=1,MTREE(IFIELD)%NPOL; MTREE(IFIELD)%POL(J)%IACT=1; END DO
   IF(IR2COUNTIMP(IFIELD,TIR))THEN
    CALL IR1FIELDS_STRING(CTREE,ITREE,IFIELD)
    DIRNAME=TRIM(RESDIR)//'\'//TRIM(ADJUSTL(CTREE(1)))//'\'//TRIM(ADJUSTL(CTREE(2)))//'\'//TRIM(CNAME)!TRIM(ADJUSTL(CTREE(3)))
!WRITE(*,*) DIRNAME
    !## dirname exists ...
    IF(IOSDIREXISTS(DIRNAME))THEN
     CALL UTL_DEL1TREE(DIRNAME)
     !## dirname still exists ... user terminated the process
     IF(.NOT.IOSDIREXISTS(DIRNAME))THEN
      !## delete tree-item ...
!     WRITE(*,*) '1:JFIELD,N=',JFIELD,N,RTREE(JFIELD)%RESULT_ID,ID,ID1
      IF(JFIELD.LE.N)CALL IR1TREEFIELD_REMOVE(JFIELD,ID1)!FIELD,ID1)
      IR1CHECKCNAME=.TRUE.
     ENDIF
    ELSE
!     WRITE(*,*) '2:JFIELD,N=',JFIELD,N,RTREE(JFIELD)%RESULT_ID,ID,ID1
     !## delete tree-item ...
     IF(JFIELD.LE.N)CALL IR1TREEFIELD_REMOVE(JFIELD,ID1)
     IR1CHECKCNAME=.TRUE.
    ENDIF
!   ELSE
!    WRITE(*,*) 'ERROR IN IR2COUNTIMP'
   ENDIF
  ENDIF
 ELSE
  IF(JFIELD.LE.N)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You cannot give a duplicate name','Error')
  ELSE
   IR1CHECKCNAME=.TRUE.
  ENDIF
 ENDIF

 END FUNCTION IR1CHECKCNAME

 !###======================================================================
 SUBROUTINE IR1TREEFIELD_REMOVE(IFIELD,ID)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IFIELD,ID
 INTEGER :: IDTMP

!WRITE(*,*) 'NRESULT=',NRESULT
 CALL WDIALOGSELECT(ID_DIR_PM)
 CALL WDIALOGGETTREEVIEW(IDF_TREEVIEW1,IDTMP)
 CALL WDIALOGDELETETREEVIEWITEM(IDF_TREEVIEW1,ID)
 CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,IDTMP)
 RTREE(IFIELD)%RESULT_ID=0
 NRESULT=NRESULT-1
!WRITE(*,*) 'NRESULT=',NRESULT

 END SUBROUTINE IR1TREEFIELD_REMOVE

 !###======================================================================
 SUBROUTINE IR1TREEFIELD(ICAT,CNAME)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ICAT
 INTEGER :: IDPOS,IPOS,IDITEM,ID,I
 CHARACTER(LEN=*),INTENT(INOUT) :: CNAME

 !## copy polygon first

 SELECT CASE (ICAT)
  !## add new scenario
  CASE (1)
!   IDPOS                   =1,TTREE(MAX(1,NTARGET))%TARGET_ID
   IDPOS                   =MAX(1,TTREE(MAX(1,NTARGET))%TARGET_ID)
   NTARGET                 =NTARGET+1
   TTREE(NTARGET)%IDPOS    =IDPOS
   TTREE(NTARGET)%TARGET_ID=IR1GETFREETREEID()
   IPOS                    =INSERTAFTER
   IDITEM                  =TTREE(NTARGET)%TARGET_ID

   !## initiate variables
   CALL IR1DEALLOCATE_TARGET(NTARGET)
   ALLOCATE(TTREE(NTARGET)%POL(MAXSHAPES))
   DO I=1,MAXSHAPES
    TTREE(NTARGET)%POL(I)%NCRD =0
    TTREE(NTARGET)%POL(I)%NDEF =0
    TTREE(NTARGET)%POL(I)%ITYPE=0
    TTREE(NTARGET)%POL(I)%IACT =0
    TTREE(NTARGET)%POL(I)%ICLR=0
    TTREE(NTARGET)%POL(I)%WIDTH=0
    TTREE(NTARGET)%POL(I)%POLNAME=''
   END DO

   !## zero polygons
   TTREE(NTARGET)%NPOL     =0
   TTREE(NTARGET)%CNAME    =CNAME
   !## set tab to "add areas"
   CALL WDIALOGSELECT(ID_DIR_PMTAB1)
   CALL WDIALOGSETTAB(IDF_TAB1,ID_DIR_PMTAB1TAB2)

  !## add new measurement
  CASE (2)

   CALL WDIALOGSELECT(ID_DIR_PM)
   CALL WDIALOGGETTREEVIEW(IDF_TREEVIEW1,ID)

   IDPOS                     =ID
   NMEASURE                  =NMEASURE+1
   MTREE(NMEASURE)%IDPOS     =IDPOS
   MTREE(NMEASURE)%MEASURE_ID=IR1GETFREETREEID()
   IPOS                      =INSERTCHILD
   IDITEM                    =MTREE(NMEASURE)%MEASURE_ID

   !## initiate variables
   CALL IR1DEALLOCATE_MEASURE(NMEASURE)
   ALLOCATE(MTREE(NMEASURE)%POL(MAXSHAPES))
   ALLOCATE(MTREE(NMEASURE)%OPT(NIR))
   DO I=1,MAXSHAPES
    MTREE(NMEASURE)%POL(I)%NCRD=0
    MTREE(NMEASURE)%POL(I)%NMES=0
    MTREE(NTARGET)%POL(I)%ITYPE=0
    MTREE(NTARGET)%POL(I)%IACT =0
    MTREE(NTARGET)%POL(I)%ICLR=0
    MTREE(NTARGET)%POL(I)%WIDTH=0
    MTREE(NTARGET)%POL(I)%POLNAME=''
   END DO

   !## zero polygons
   MTREE(NMEASURE)%NPOL      =0
   MTREE(NMEASURE)%CNAME     =CNAME
   MTREE(NMEASURE)%NOPT      =0

   !## set tab to "add areas"
   CALL WDIALOGSELECT(ID_DIR_PMTAB2)
   CALL WDIALOGSETTAB(IDF_TAB1,ID_DIR_PMTAB2TAB2)

  !## add new result
  CASE (3)

   CALL WDIALOGSELECT(ID_DIR_PM)
   CALL WDIALOGGETTREEVIEW(IDF_TREEVIEW1,ID)

   IDPOS                   =ID
   NRESULT                 =NRESULT+1
   RTREE(NRESULT)%IDPOS    =IDPOS
   RTREE(NRESULT)%RESULT_ID=IR1GETFREETREEID()
   IPOS                    =INSERTCHILD
   IDITEM                  =RTREE(NRESULT)%RESULT_ID
   RTREE(NRESULT)%CNAME    =CNAME

   !## set tab to "results"
   CALL WDIALOGSELECT(ID_DIR_PMTAB3)
   CALL WDIALOGSETTAB(IDF_TAB1,ID_DIR_PMTAB3TAB1)

 END SELECT

!WRITE(*,*) IDPOS,IPOS,IDITEM,TRIM(CNAME)

 CALL WDIALOGSELECT(ID_DIR_PM)
 CALL WDIALOGINSERTTREEVIEWITEM(IDF_TREEVIEW1,IDPOS,IPOS,IDITEM,TRIM(CNAME))!// &
!  ' IDPOS:'//TRIM(ITOS(IDPOS))//';_ID:'//TRIM(ITOS(IDITEM)))
 CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,IDITEM)

 !## draw previous shape
 CALL IR1FIELDS_MAIN()

 END SUBROUTINE IR1TREEFIELD

 !###======================================================================
 SUBROUTINE IR1MAIN(ITYPE,MESSAGE)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ITYPE
 TYPE(WIN_MESSAGE) :: MESSAGE

 CALL WDIALOGSELECT(MESSAGE%WIN)

 SELECT CASE (MESSAGE%WIN)

  !## project manager
  CASE (ID_DIR_PM)

   SELECT CASE(ITYPE)

    CASE (FIELDCHANGED)

     SELECT CASE (MESSAGE%VALUE2)
      CASE (IDF_TREEVIEW1)
       CALL IR1FIELDS_MAIN()
     END SELECT

    CASE(TABCHANGED)

    CASE(PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      !## close ir qstool
      CASE (IDCANCEL)
       CALL IR1CLOSE(1)
      CASE (ID_NEWTARGET,ID_NEWMEASURE,ID_NEWRESULTS)
       IF(.NOT.IR1NEW(MESSAGE%VALUE1,1))THEN
       ENDIF
      CASE (ID_RENAME)
       CALL IR1RENAME()
      CASE (ID_COPY)
       CALL IR1COPYTREE()
      CASE (ID_DELETE)
       CALL IR1DELETETREE()
     END SELECT

   END SELECT

  !## main targets tab
  CASE (ID_DIR_PMTAB1)
   SELECT CASE(ITYPE)
    CASE (TABCHANGED)
!     CALL IR1EDITSHAPES(ID_DIR_PMTAB1,MESSAGE%VALUE2)
    CASE (PUSHBUTTON)
     IF(.NOT.IR1NEW(ID_NEWMEASURE,1))THEN
     ENDIF
   END SELECT

  !## targets
  CASE (ID_DIR_PMTAB1TAB1)

   SELECT CASE(ITYPE)
    CASE (FIELDCHANGED)
     SELECT CASE (MESSAGE%VALUE2)
     END SELECT
     SELECT CASE (MESSAGE%VALUE1)
     END SELECT
    CASE(PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      CASE (ID_ADD)
       CALL IR1TARGETS()
      CASE (ID_COPY)
       CALL IR1COPY()
     END SELECT
   END SELECT

  !## polygons
  CASE (ID_DIR_PMTAB1TAB2)

   ICLRPOLG=ICLRTARGET
   IACTSHAPES=(/3,3,1,3,3,3/)
   CALL POLYGON1MAIN(ITYPE,MESSAGE)

   SELECT CASE(ITYPE)
    CASE (PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      CASE (ID_DELETE)
       CALL IR1DELETEPOLYGONS(1)
     END SELECT
   END SELECT

   SELECT CASE(ITYPE)
    CASE (PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      !## copy from available polygons
      CASE (ID_GENCOPY)
       CALL IR1GENCOPY(ID_DIR_PMTAB1TAB2)
      !## make sure the information of the current polygon is removed too!
     END SELECT
    CASE (FIELDCHANGED)
     SELECT CASE (MESSAGE%VALUE1)
     !## draw again to plot information
     END SELECT
   END SELECT

   CALL IR1FIELDS_TAB1()

  !## main measures tab
  CASE (ID_DIR_PMTAB2)
   SELECT CASE(ITYPE)
    CASE (TABCHANGED)
!     CALL IR1EDITSHAPES(ID_DIR_PMTAB2,MESSAGE%VALUE2)
    CASE (FIELDCHANGED)
     SELECT CASE (MESSAGE%VALUE1)
      CASE (IDF_CHECK2,IDF_MENU2)
       CALL IR_SELECTEDCELLS()
     END SELECT
    CASE (PUSHBUTTON)
     IF(.NOT.IR1NEW(ID_NEWRESULTS,1))THEN
     ENDIF
   END SELECT

  !## measures
  CASE (ID_DIR_PMTAB2TAB1)

   SELECT CASE(ITYPE)
    CASE (FIELDCHANGED)
     SELECT CASE (MESSAGE%VALUE1)
     END SELECT
    CASE(PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      CASE (ID_COPY)
       CALL IR1COPY()
      CASE (ID_ADD)
       CALL IR1MEASURES()
     END SELECT
   END SELECT

  !## shapes
  CASE (ID_DIR_PMTAB2TAB2)

   ICLRPOLG=ICLRMEASURE
   IACTSHAPES=(/3,3,1,3,3,3/)
   CALL POLYGON1MAIN(ITYPE,MESSAGE)

   SELECT CASE(ITYPE)
    CASE (PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      CASE (ID_DELETE)
       CALL IR1DELETEPOLYGONS(2)
     END SELECT
   END SELECT

   SELECT CASE(ITYPE)
    CASE (PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      !## copy from available polygons
      CASE (ID_GENCOPY)
       CALL IR1GENCOPY(ID_DIR_PMTAB2TAB2)
     END SELECT
!    CASE (FIELDCHANGED)
!     SELECT CASE (MESSAGE%VALUE1)
      !## plot measure on map, draw again to plot information
!      CASE (IDF_CHECK1)
      !## plot selected polygons
!      CASE (IDF_MENU1)
!       CALL IR_SELECTEDCELLS()
!     END SELECT
   END SELECT

   CALL IR1FIELDS_TAB2()
   !## fields on main measure tab
   CALL IR_SELECTEDCELLS()

  !## optimize
  CASE (ID_DIR_PMTAB2TAB4)
   SELECT CASE(ITYPE)
    CASE (PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      !## define constraints
      CASE (ID_ADD)
       CALL IR1INVERSE()
       CALL IR1FIELDS_WRITETAB2TAB4()
      !## print report
      CASE (ID_REPORT)
       CALL IR1LINEAR_VIEWOUTPUT()
      CASE (ID_INVERSEIR)
       !## selected polygons only!
       CALL IR1COMPUTEIR(.TRUE.,.TRUE.)
       CALL IR2DEALLOCATE()
       CALL IR21DEALLOCATE()

     END SELECT
    CASE (FIELDCHANGED)
     !## move or current field
     SELECT CASE (MESSAGE%VALUE2)
     END SELECT
   END SELECT

  !## preview
  CASE (ID_DIR_PMTAB2TAB3)
   SELECT CASE(ITYPE)
    CASE (PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      CASE (ID_APPLY)
       CALL IR1COMPUTEIR(.TRUE.,.FALSE.)  !LQUICK,LINV,POL
       CALL IR2DEALLOCATE()
       CALL IR21DEALLOCATE()
     END SELECT
    CASE (FIELDCHANGED)
     !## move or current field
     SELECT CASE (MESSAGE%VALUE2)
      CASE (IDF_MENU1) !## period
       CALL IR1FIELDS_PLOTLABELUNIT()
     END SELECT
    CASE (EXPOSE,RESIZE)
     !## redraw legend
     CALL LEGPLOT_MAIN(ID_DIR_PMTAB2TAB3,IDF_PICTURE1,3)  !## three columns

   END SELECT

  !## results
  CASE (ID_DIR_PMTAB3)

   SELECT CASE(ITYPE)
    CASE (TABCHANGED)
     SELECT CASE (MESSAGE%VALUE2)
      CASE (ID_DIR_PMTAB3TAB1)
       CALL IR1FIELDS_TAB3_PLOTRES()
      CASE (ID_DIR_PMTAB3TAB2)
!       CALL IR1FIELDS_TAB3_CALCDIFF()
       CALL IR1FIELDS_TAB3TAB2()
     END SELECT
    CASE (FIELDCHANGED)
     SELECT CASE (MESSAGE%VALUE1)
     END SELECT
    CASE(PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
     END SELECT
   END SELECT

  !## results-list
  CASE (ID_DIR_PMTAB3TAB1)

   SELECT CASE(ITYPE)
    CASE (FIELDCHANGED)
     SELECT CASE (MESSAGE%VALUE2)
      CASE (IDF_MENU1)
       !## plot selected topic
       IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)THEN
        CALL IR1FIELDS_PLOTLABELUNIT()
        CALL IR1FIELDS_TAB3_PLOTRES()
       ENDIF
     END SELECT
    CASE (PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
     END SELECT
    CASE (EXPOSE,RESIZE)
     !## redraw legend
     CALL LEGPLOT_MAIN(ID_DIR_PMTAB3TAB1,IDF_PICTURE1,3)  !## three columns
   END SELECT

  !## results-target options
  CASE (ID_DIR_PMTAB3TAB2)

   SELECT CASE(ITYPE)
    CASE (FIELDCHANGED)
     SELECT CASE (MESSAGE%VALUE2)
      CASE (IDF_MENU1)
       !## plot selected topic
       IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)CALL IR1FIELDS_PLOTLABELUNIT()
     END SELECT
    CASE (PUSHBUTTON)
     SELECT CASE (MESSAGE%VALUE1)
      CASE (ID_CALC)
       CALL IR1FIELDS_TAB3_CALCDIFF()
     END SELECT
    CASE (EXPOSE,RESIZE)
     !## redraw legend
     CALL LEGPLOT_MAIN(ID_DIR_PMTAB3TAB2,IDF_PICTURE1,4)  !## four columns

   END SELECT

 END SELECT

 END SUBROUTINE IR1MAIN

 !###======================================================================
 SUBROUTINE IR1COPYTREE()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: ITREE,IFIELD,ITARGET,JTREE,I,J,NCRD,NOPT,NMES

 !## get level of treeview
 CALL WDIALOGSELECT(ID_DIR_PM)
 CALL IR1GETTREEVIEWID(ITREE,IFIELD)

! WRITE(*,*) MTREE(IFIELD)%NPOL
 !## copy data of current measures
 CALL IR1SHAPE2POL(ITREE,IFIELD)
 !## restore them again ...
 CALL IR1POL2SHAPE(ITREE,IFIELD)
! WRITE(*,*) MTREE(IFIELD)%NPOL

 CALL WDIALOGSELECT(ID_DIR_PM)

 SELECT CASE (ITREE)
  !## targets
  CASE (1)
!   CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,IDITEM)
   IF(.NOT.IR1NEW(ID_NEWTARGET,1))RETURN
  !## measures
  CASE (2)
   !## get target id
   I=MTREE(IFIELD)%IDPOS
   CALL IR1GETTREEID(JTREE,ITARGET,I)
   J=TTREE(ITARGET)%TARGET_ID
   CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,J)
   IF(.NOT.IR1NEW(ID_NEWMEASURE,1))THEN
    CALL WDIALOGSELECT(ID_DIR_PM)
    CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,I)
    !## restore them again ...
    CALL IR1POL2SHAPE(ITREE,IFIELD)
    RETURN
   ENDIF
  !## results --- ook hernoemen van de directory ...
  CASE (3)
! !## get measure id
! I=RTREE(IFIELD)%IDPOS
! CALL IR1GETTREEID(ITREE,IMEASURE,I)
!   CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,IDITEM)
!   IF(.NOT.IR1NEW(ID_NEWRESULTS,1))RETURN
 END SELECT

! WRITE(*,*) MTREE(IFIELD)%NPOL

!WRITE(*,*) MTREE(IFIELD)%NPOL
!WRITE(*,*) MTREE(IFIELD)%NPOL
! !## restore them again ...
! CALL IR1POL2SHAPE(ITREE,IFIELD)
!WRITE(*,*) MTREE(IFIELD)%NPOL

 !## copy all selected polygons
 IF(ITREE.EQ.1)THEN
  TTREE(NTARGET)%NPOL=TTREE(IFIELD)%NPOL
!  TTREE(NTARGET)%TARGET_ID=IR1GETFREETREEID()
  DO I=1,TTREE(NTARGET)%NPOL

   TTREE(NTARGET)%POL(I)%ITYPE  =TTREE(IFIELD)%POL(I)%ITYPE
   TTREE(NTARGET)%POL(I)%IACT   =TTREE(IFIELD)%POL(I)%IACT
   TTREE(NTARGET)%POL(I)%ICLR   =TTREE(IFIELD)%POL(I)%ICLR
   TTREE(NTARGET)%POL(I)%WIDTH  =TTREE(IFIELD)%POL(I)%WIDTH
   TTREE(NTARGET)%POL(I)%POLNAME=TTREE(IFIELD)%POL(I)%POLNAME
!   TTREE(NTARGET)%POL(I)%EFFECT =TTREE(IFIELD)%POL(I)%EFFECT

   TTREE(NTARGET)%POL(I)%NDEF   =TTREE(IFIELD)%POL(I)%NDEF
   IF(.NOT.ASSOCIATED(TTREE(NTARGET)%POL(I)%DEF))THEN
    ALLOCATE(TTREE(NTARGET)%POL(I)%DEF(MAXDEF))
   ENDIF
   TTREE(NTARGET)%POL(I)%NDEF=TTREE(IFIELD)%POL(I)%NDEF
   TTREE(NTARGET)%POL(I)%DEF =TTREE(IFIELD)%POL(I)%DEF

   TTREE(NTARGET)%POL(I)%NCRD=TTREE(IFIELD)%POL(I)%NCRD
   NCRD=TTREE(NTARGET)%POL(I)%NCRD
   IF(NCRD.GT.0)THEN
    IF(.NOT.ASSOCIATED(TTREE(NTARGET)%POL(I)%X))THEN
     ALLOCATE(TTREE(NTARGET)%POL(I)%X(NCRD))
    ENDIF
    IF(.NOT.ASSOCIATED(TTREE(NTARGET)%POL(I)%Y))THEN
     ALLOCATE(TTREE(NTARGET)%POL(I)%Y(NCRD))
    ENDIF
    TTREE(NTARGET)%POL(I)%X=TTREE(IFIELD)%POL(I)%X
    TTREE(NTARGET)%POL(I)%Y=TTREE(IFIELD)%POL(I)%Y
   ENDIF

  ENDDO

 ENDIF

 !## copy measure
 IF(ITREE.EQ.2)THEN

! WRITE(*,*) MTREE(IFIELD)%NPOL
!WRITE(*,*) MTREE(NMEASURE)%MEASURE_ID,MTREE(NMEASURE)%IDPOS
!  MTREE(NMEASURE)%MEASURE_ID=IR1GETFREETREEID()

  NOPT=MTREE(IFIELD)%NOPT
  IF(NOPT.GT.0)THEN
   IF(.NOT.ASSOCIATED(MTREE(NMEASURE)%OPT))THEN
    ALLOCATE(MTREE(NMEASURE)%OPT(NOPT))
   ENDIF
   MTREE(NMEASURE)%OPT =MTREE(IFIELD)%OPT
  ENDIF

  MTREE(NMEASURE)%NPOL=MTREE(IFIELD)%NPOL

!  WRITE(*,*) NMEASURE,MTREE(NMEASURE)%NPOL

  DO J=1,MTREE(NMEASURE)%NPOL
   MTREE(NMEASURE)%POL(J)%ITYPE  =MTREE(IFIELD)%POL(J)%ITYPE
   MTREE(NMEASURE)%POL(J)%IACT   =MTREE(IFIELD)%POL(J)%IACT
   MTREE(NMEASURE)%POL(J)%ICLR   =MTREE(IFIELD)%POL(J)%ICLR
   MTREE(NMEASURE)%POL(J)%WIDTH  =MTREE(IFIELD)%POL(J)%WIDTH
   MTREE(NMEASURE)%POL(J)%POLNAME=MTREE(IFIELD)%POL(J)%POLNAME

   MTREE(NMEASURE)%POL(J)%NMES   =MTREE(IFIELD)%POL(J)%NMES
   NMES=MTREE(NMEASURE)%POL(J)%NMES
   IF(NMES.GT.0)THEN
    IF(.NOT.ASSOCIATED(MTREE(NMEASURE)%POL(J)%MES))THEN
     ALLOCATE(MTREE(NMEASURE)%POL(J)%MES(MAXMES))
    ENDIF
    MTREE(NMEASURE)%POL(J)%MES =MTREE(IFIELD)%POL(J)%MES
   ENDIF

   MTREE(NMEASURE)%POL(I)%NCRD=MTREE(IFIELD)%POL(I)%NCRD
   NCRD=MTREE(NMEASURE)%POL(I)%NCRD
   IF(NCRD.GT.0)THEN
    IF(.NOT.ASSOCIATED(MTREE(NMEASURE)%POL(I)%X))THEN
     ALLOCATE(MTREE(NMEASURE)%POL(I)%X(NCRD))
    ENDIF
    IF(.NOT.ASSOCIATED(MTREE(NMEASURE)%POL(I)%Y))THEN
     ALLOCATE(MTREE(NMEASURE)%POL(I)%Y(NCRD))
    ENDIF
    MTREE(NMEASURE)%POL(I)%X=MTREE(IFIELD)%POL(I)%X
    MTREE(NMEASURE)%POL(I)%Y=MTREE(IFIELD)%POL(I)%Y
   ENDIF

  END DO
 ENDIF

! WRITE(*,*) MTREE(NMEASURE)%NPOL
 CALL IR1FILLTREEVIEW()
! WRITE(*,*) MTREE(NMEASURE)%NPOL
 IF(ITREE.EQ.1)CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,TTREE(NTARGET)%TARGET_ID)
 IF(ITREE.EQ.2)CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,MTREE(NMEASURE)%MEASURE_ID)
 IF(ITREE.EQ.3)CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,RTREE(NRESULT)%RESULT_ID)

 !## restore them again ...
 CALL IR1GETTREEVIEWID(ITREE,IFIELD)
 CALL IR1POL2SHAPE(ITREE,IFIELD)

 !## redraw wscene
 CALL IDFPLOT(1)
 ICUR_ITREE =0
 ICUR_IFIELD=0
 CALL IR1FIELDS_MAIN()
! WRITE(*,*) MTREE(NMEASURE)%NPOL

 END SUBROUTINE IR1COPYTREE

 !###======================================================================
 SUBROUTINE IR1DELETETREE()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: ITREE,IFIELD,I,J,IDT,IDM
 CHARACTER(LEN=MAXLEN) :: CNAME

 !## get level of treeview
 CALL WDIALOGSELECT(ID_DIR_PM)
 CALL IR1GETTREEVIEWID(ITREE,IFIELD)

 SELECT CASE (ITREE)
  !## targets
  CASE (1)
   CNAME=TTREE(IFIELD)%CNAME
  !## measures
  CASE (2)
   CNAME=MTREE(IFIELD)%CNAME
  !## results
  CASE (3)
   CNAME=RTREE(IFIELD)%CNAME
 END SELECT

 CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete '//TRIM(CNAME)//' ?','Question')
 IF(WINFODIALOG(4).NE.1)RETURN

 CALL WDIALOGGETTREEVIEW(IDF_TREEVIEW1,IDT)
 CALL WDIALOGDELETETREEVIEWITEM(IDF_TREEVIEW1,IDT)
 CALL IR1FIELDS_MAIN()

! RETURN

 SELECT CASE (ITREE)
  !## targets
  CASE (1)
   IDT=TTREE(IFIELD)%TARGET_ID
   DO I=1,NMEASURE
    !## delete all measures connected to target
    IF(MTREE(I)%IDPOS.EQ.IDT)THEN
     IDM=MTREE(I)%MEASURE_ID
     DO J=1,NRESULT
      IF(RTREE(J)%IDPOS.EQ.IDM)RTREE(J)%IDPOS=0
     END DO
     MTREE(I)%IDPOS=0
    ENDIF
   END DO
   TTREE(IFIELD)%IDPOS=0
  !## measures
  CASE (2)
   IDM=MTREE(IFIELD)%MEASURE_ID
   DO I=1,NRESULT
    IF(RTREE(I)%IDPOS.EQ.IDM)RTREE(I)%RESULT_ID=0
   END DO
   MTREE(IFIELD)%IDPOS=0
  !## results
  CASE (3)
   RTREE(IFIELD)%IDPOS=0
 END SELECT

 !## write tmp-project
 IF(.NOT.IR1PRJFILES(ID_SAVE,FNAME=TRIM(PREFVAL(1))//'\TMP\TMP.QPF'))RETURN
 !## reread it
 IF(.NOT.IR1PRJFILES(ID_OPEN,FNAME=TRIM(PREFVAL(1))//'\TMP\TMP.QPF'))RETURN

 !## fill treeview
 CALL IR1FILLTREEVIEW()
 !## redraw wscene
 CALL IDFPLOT(1)
 ICUR_ITREE =0
 ICUR_IFIELD=0
 CALL IR1FIELDS_MAIN()

 END SUBROUTINE IR1DELETETREE

 !###======================================================================
 SUBROUTINE IR1DELETEPOLYGONS(IC)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IC
 INTEGER :: IPOL1,IPOL2,ITREE,IFIELD

! IF(IC.EQ.1)CALL WDIALOGSELECT(ID_DIR_PMTAB1TAB2)
! IF(IC.EQ.2)CALL WDIALOGSELECT(ID_DIR_PMTAB2TAB2)

! CALL WDIALOGGETMENU(IDF_MENU1,SHPIACT)

 !## get level of treeview
 CALL IR1GETTREEVIEWID(ITREE,IFIELD)

 IF(IC.EQ.1)THEN

  IPOL2=0

  IF(SHPNO.EQ.TTREE(IFIELD)%NPOL)THEN!RETURN

! WRITE(*,*) SHPIACT(1:SHPNO)

! N=0
! DO I=1,SHPNO
!  IF(SHPIACT(I).EQ.1)THEN
!   !## remove selected
!   CALL POLYGON1DRAWSHAPE(I,I)
!  ELSE
!   N=N+1
!   IF(N.NE.I)THEN
!    SHPXC(:,N) =SHPXC(:,I)
!    SHPYC(:,N) =SHPYC(:,I)
!    SHPNCRD(N) =SHPNCRD(I)
!    SHPCOLOR(N)=SHPCOLOR(I)
!    SHPNAME(N) =SHPNAME(I)
!    SHPTYPE(N) =SHPTYPE(I)
!   ENDIF
!  ENDIF
! END DO

   !## copy all non-selected polygons and their associated information
   DO IPOL1=1,SHPNO
    IF(TTREE(IFIELD)%POL(IPOL1)%IACT.EQ.0)THEN
     IPOL2=IPOL2+1
     !## not equal, so copying
     IF(IPOL1.NE.IPOL2)THEN
      !## copy information assigned to ipol1 towards ipol2
      CALL IR1COPY_TARGET(IFIELD,IPOL1,IPOL2)
     ENDIF
    ELSE
     TTREE(IFIELD)%POL(IPOL1)%NDEF=0
    ENDIF
   END DO
  ENDIF

  IPOL2=IPOL2+1
  !## clean removed definition fields
  !## polygon information is adjusted in polygon1delete()
  DO IPOL1=IPOL2,MAXSHAPES
   !## already target to assigned - clean memory
   IF(TTREE(IFIELD)%POL(IPOL1)%NDEF.GT.0)THEN
    CALL IR1DEALLOCATE_TARGET2(IFIELD,IPOL1)
   ENDIF
   !## initialize number of definitions
   TTREE(IFIELD)%POL(IPOL1)%NDEF=0
   TTREE(IFIELD)%POL(IPOL1)%NCRD=0
  END DO

 ELSEIF(IC.EQ.2)THEN

!WRITE(*,*) SHPNO,MTREE(IFIELD)%NPOL

  IPOL2=0

  IF(SHPNO.EQ.MTREE(IFIELD)%NPOL)THEN!RETURN

   !## copy all non-selected polygons and their associated information
   DO IPOL1=1,SHPNO
    IF(MTREE(IFIELD)%POL(IPOL1)%IACT.EQ.0)THEN
     IPOL2=IPOL2+1
     !## not equal, so copying
     IF(IPOL1.NE.IPOL2)THEN
      !## copy information assigned to ipol1 towards ipol2
      CALL IR1COPY_MEASURE(IFIELD,IPOL1,IPOL2)
     ENDIF
    ELSE
     MTREE(IFIELD)%POL(IPOL1)%NMES=0
    ENDIF
!WRITE(*,*) IPOL1,SHPNO,MTREE(IFIELD)%POL(IPOL1)%NMES
   END DO
!WRITE(*,*) 'SHPNO=',SHPNO
  ENDIF

!  WRITE(*,*) 'IPOL2=',IPOL2
  IPOL2=IPOL2+1
  !## clean removed definition fields
  !## polygon information is adjusted in polygon1delete()
  DO IPOL1=IPOL2,MAXSHAPES!SHPNO
   !## already target to assigned - clean memory
   IF(MTREE(IFIELD)%POL(IPOL1)%NMES.GT.0)THEN
    CALL IR1DEALLOCATE_MEASURE2(IFIELD,IPOL1)
   ENDIF
   MTREE(IFIELD)%POL(IPOL1)%NMES=0
   MTREE(IFIELD)%POL(IPOL1)%NCRD=0
  END DO

 ENDIF

 END SUBROUTINE IR1DELETEPOLYGONS

 !###======================================================================
! SUBROUTINE IR1EDITSHAPES(ID,IDT)
 !###======================================================================
! IMPLICIT NONE
! INTEGER,INTENT(IN) :: ID,IDT

 !## turn to new tab, turn on/off polygon to be edited yes/no
! SELECT CASE (ID)
!  CASE (ID_DIR_PMTAB1)
!   SELECT CASE (IDT)
!    !## target definition
!    CASE (ID_DIR_PMTAB1TAB1)
!     ISHPEDIT=0
!    !## polygons editable
!    CASE (ID_DIR_PMTAB1TAB2)
!     ISHPEDIT=1
!   END SELECT
!  CASE (ID_DIR_PMTAB2)
!   SELECT CASE (IDT)
!    !## measurement,preview
!    CASE (ID_DIR_PMTAB2TAB1,ID_DIR_PMTAB2TAB3)
!     ISHPEDIT=0
!    !## polygons editable
!    CASE (ID_DIR_PMTAB2TAB2)
!     ISHPEDIT=1
!   END SELECT
! END SELECT

!WRITE(*,*) shpno

! END SUBROUTINE IR1EDITSHAPES

 !###======================================================================
 SUBROUTINE IR1COPY()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: ITYPE
 TYPE(WIN_MESSAGE) :: MESSAGE
 INTEGER :: ITREE,IFIELD,IPOL1,IPOL2

 !## get level of treeview
 CALL IR1GETTREEVIEWID(ITREE,IFIELD)
 !## read current number of polygons
 CALL IR1SHAPE2POL(ITREE,IFIELD)
 CALL IR1POL2SHAPE(ITREE,IFIELD)

 CALL WDIALOGLOAD(ID_DCOPYLEGEND,ID_DCOPYLEGEND)
 !## targets copy
 IF(ITREE.EQ.1)THEN
  CALL WDIALOGPUTMENU(IDF_MENU1,TTREE(IFIELD)%POL%POLNAME,TTREE(IFIELD)%NPOL,1)
  CALL WDIALOGTITLE('Copy TARGETS from:')
 ENDIF
 !## measures copy
 IF(ITREE.EQ.2)THEN
  CALL WDIALOGPUTMENU(IDF_MENU1,MTREE(IFIELD)%POL%POLNAME,MTREE(IFIELD)%NPOL,1)
  CALL WDIALOGTITLE('Copy MEASURE from:')
 ENDIF
 CALL WDIALOGSHOW(-1,-1,0,3)
 IPOL2=0
 DO
  CALL WMESSAGE(ITYPE,MESSAGE)
  IF(ITYPE.EQ.PUSHBUTTON)THEN
   IF(MESSAGE%VALUE1.EQ.IDOK)CALL WDIALOGGETMENU(IDF_MENU1,IPOL2)
   EXIT
  ENDIF
 ENDDO
 CALL WDIALOGUNLOAD()

!WRITE(*,*) IPOL2

 !## nothing to do
 IF(IPOL2.EQ.0)RETURN

 !# copy all selected polygons
 IF(ITREE.EQ.1)THEN
  DO IPOL1=1,TTREE(IFIELD)%NPOL
   IF(IPOL1.NE.IPOL2.AND.TTREE(IFIELD)%POL(IPOL1)%IACT.EQ.1)THEN
    !## only copy whenever there is something to copy at all!
    IF(TTREE(IFIELD)%POL(IPOL2)%NDEF.GT.0)THEN
!     TTREE(IFIELD)%POL(IPOL1)%EFFECT=TTREE(IFIELD)%POL(IPOL2)%EFFECT
     IF(.NOT.ASSOCIATED(TTREE(IFIELD)%POL(IPOL1)%DEF))THEN
      ALLOCATE(TTREE(IFIELD)%POL(IPOL1)%DEF(MAXDEF))
     ENDIF
     TTREE(IFIELD)%POL(IPOL1)%NDEF=TTREE(IFIELD)%POL(IPOL2)%NDEF
     TTREE(IFIELD)%POL(IPOL1)%DEF =TTREE(IFIELD)%POL(IPOL2)%DEF
    ENDIF
   ENDIF
  ENDDO
  CALL IR1FIELDS_WRITETAB1(IFIELD)
 ELSEIF(ITREE.EQ.2)THEN
  DO IPOL1=1,MTREE(IFIELD)%NPOL
   IF(IPOL1.NE.IPOL2.AND.MTREE(IFIELD)%POL(IPOL1)%IACT.EQ.1)THEN
    !## only copy whenever there is something to copy at all!
    IF(MTREE(IFIELD)%POL(IPOL2)%NMES.GT.0)THEN
     IF(.NOT.ASSOCIATED(MTREE(IFIELD)%POL(IPOL1)%MES))THEN
      ALLOCATE(MTREE(IFIELD)%POL(IPOL1)%MES(MAXMES))
     ENDIF
     MTREE(IFIELD)%POL(IPOL1)%NMES=MTREE(IFIELD)%POL(IPOL2)%NMES
     MTREE(IFIELD)%POL(IPOL1)%MES =MTREE(IFIELD)%POL(IPOL2)%MES
    ENDIF
   ENDIF
  END DO
  CALL IR1FIELDS_WRITETAB2(IFIELD)
 ENDIF

 END SUBROUTINE IR1COPY

 !###======================================================================
 SUBROUTINE IR1MENU(ITYPE,MESSAGE)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ITYPE
 TYPE(WIN_MESSAGE) :: MESSAGE
 INTEGER :: I,J

 IF(ITYPE.EQ.CLOSEREQUEST)THEN
  CALL IR1CLOSE(1)
 ELSEIF(ITYPE.EQ.MENUSELECT)THEN
!  IF(MESSAGE%WIN.EQ.IRWIN)THEN
   CALL WINDOWSELECT(IRWIN)

   SELECT CASE (MESSAGE%VALUE1)
    !## zooming maps
    CASE(ID_ZOOMINMAP,ID_ZOOMOUTMAP,ID_ZOOMRECTANGLEMAP,ID_ZOOMFULLMAP,ID_ZOOMTAG)
!    CALL IDFMENUFIELDS(MESSAGE%VALUE1,1,0)
     CALL IDFZOOM(MESSAGE%VALUE1,(MPW%XMAX+MPW%XMIN)/2.0,(MPW%YMAX+MPW%YMIN)/2.0,0)
     CALL IDFPLOTFAST(1)
!    CALL IDFMENUFIELDS(MESSAGE%VALUE1,0,1)
    CASE(ID_MOVEMAP)
!  CALL IDFMENUFIELDS(MESSAGE%VALUE1,1,0)
     CALL IDFMOVE(0)
!  CALL IDFMENUFIELDS(MESSAGE%VALUE1,0,1)
    CASE (ID_RENAME)
     CALL IR1RENAME()
    !## refresh totally
    CASE (ID_NEW)
     CALL IR1CLOSE(1)
     CALL IR1INIT()
    !## open new qs-project
    CASE (ID_OPEN)
     IF(IR1PRJFILES(ID_OPEN))THEN
      !## fill treeview
      CALL IR1FILLTREEVIEW()
      !## redraw wscene
      CALL IDFPLOT(1)
      ICUR_ITREE =0
      ICUR_IFIELD=0
      CALL IR1FIELDS_MAIN()
     ENDIF
    CASE (ID_SAVE,ID_SAVEAS)
     IF(.NOT.IR1PRJFILES(MESSAGE%VALUE1,IQUESTION=1))THEN
     ENDIF
    CASE (ID_QUIT,CLOSEREQUEST)
     CALL IR1CLOSE(1)
   END SELECT

   DO I=1,MAXDV
    IF(MESSAGE%VALUE1.EQ.IDV(I))THEN
     J=WMENUGETSTATE(MESSAGE%VALUE1,2)
!     WRITE(*,*) J,ABS(J-1)
     J=ABS(J-1)
     CALL WMENUSETSTATE(MESSAGE%VALUE1,2,J)
     CALL IDFPLOT(1)
     EXIT
    ENDIF
   END DO

!  ENDIF
 ENDIF

 END SUBROUTINE IR1MENU

 !###======================================================================
 SUBROUTINE IR1INIT()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: IFLAGS,I,IBC,ITYPE,J
 TYPE(WIN_MESSAGE) :: MESSAGE

 !## close if opened already
 CALL WINDOWSELECT(0)
 IF(WMENUGETSTATE(ID_IRDATABASE,2).EQ.1)THEN
  CALL IR1CLOSE(1)
  RETURN
 ENDIF

 CALL MAIN1INACTMODULE(ID_IRDATABASE)

 !## other module no closed, no approvement given
 IF(IDIAGERROR.EQ.1)RETURN

 CALL WMENUSETSTATE(ID_IRDATABASE,2,1)

 IF(.NOT.IOSDIREXISTS(TRIM(PREFVAL(1))//'\QSRESULTS'))CALL UTL_CREATEDIR(TRIM(PREFVAL(1))//'\QSRESULTS')

 !## deallocate all memory still available after previous session, should be off course!
 CALL IR1DEALLOCATE()

 ICLRMEASURE=WRGB(0,0,255)
 ICLRTARGET =WRGB(255,0,0)

 CALL IR1ALLOCATE_INIT()

 !## read ir-settings file
 IF(.NOT.IR1INITFILES())THEN
  CALL IR1CLOSE(0)
  RETURN
 ENDIF

 !## neccessary to allocate memory in imod_ir_qpf.f90
 CALL WDIALOGLOAD(ID_DIRMEASURES,ID_DIRMEASURES)
 MAXMES=WINFOGRID(IDF_GRID1,GRIDROWSMAX)
 CALL WDIALOGLOAD(ID_DIRTARGETS,ID_DIRTARGETS)
 MAXDEF=WINFOGRID(IDF_GRID1,GRIDROWSMAX)

 !## initialize project-name
 PRJFNAME=''

 !## start start dialoog
 CALL START_MAIN('QPF',I)
 IF(I.EQ.0)THEN
  CALL IR1CLOSE(0)
  RETURN
 ENDIF

 !## get prjfname
 IF(PRJFNAME.EQ.'')THEN
  CALL WDIALOGLOAD(ID_POLYGONSHAPENAME,ID_POLYGONSHAPENAME)
  CALL WDIALOGFIELDSTATE(IDHELP,3)
  CALL WDIALOGTITLE('Quick-Scan Project Name')
  CALL WDIALOGPUTSTRING(IDF_LABEL1,'Give name of the Quick-Scan Project')
  CALL WDIALOGPUTSTRING(IDF_STRING1,'')
  CALL WDIALOGSHOW(-1,-1,0,3)
  DO
   CALL WMESSAGE(ITYPE,MESSAGE)
   IF(ITYPE.EQ.PUSHBUTTON)THEN
    IF(MESSAGE%VALUE1.EQ.IDOK)CALL WDIALOGGETSTRING(IDF_STRING1,PRJFNAME)
    EXIT
   ENDIF
  ENDDO
  CALL WDIALOGUNLOAD()
  !## still no projectname given ... stop it!
  IF(MESSAGE%VALUE1.EQ.IDCANCEL)THEN
   CALL IR1CLOSE(1)
   RETURN
  ENDIF
  PRJFNAME=TRIM(MAINRESDIR)//'\'//TRIM(PRJFNAME)//'.qpf'
 ENDIF

 I=INDEX(PRJFNAME,'\',.TRUE.)+1
 J=INDEX(PRJFNAME,'.',.TRUE.)-1
 RESDIR=TRIM(MAINRESDIR)//'\'//PRJFNAME(I:J)

!WRITE(*,*) TRIM(RESDIR)

 IFLAGS=SYSMENUON+MINBUTTON+MAXBUTTON+STATUSBAR+OWNEDBYPARENT
 CALL WINDOWOPENCHILD(IRWIN,FLAGS=IFLAGS,MENUID=ID_MENU6,     &
                      TOOLID  =(/ID_TOOLBAR3,0,0,0/),        &
                      DIALOGID=ID_DIR_PM, &
                      TITLE   ='Quick Scan Tool')
 CALL WINDOWSTATUSBARPARTS(1,(/-1/),(/1/))

 CALL WDIALOGSELECT(ID_DIR_PM)
 CALL WDIALOGPUTIMAGE(ID_DELETE,ID_ICONDELETE,1)
 CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1)
 CALL WDIALOGPUTIMAGE(ID_COPY,ID_ICONCOPY,1)
 CALL WDIALOGPUTIMAGE(ID_NEWTARGET,ID_ICONTARGETS,1)
 CALL WDIALOGPUTIMAGE(ID_NEWMEASURE,ID_ICONMEASURE,1)
 CALL WDIALOGPUTIMAGE(ID_NEWRESULTS,ID_ICONCALC,1)

 CALL WDIALOGFIELDSTATE(ID_COPY,0)
 CALL WDIALOGFIELDSTATE(ID_DELETE,0)
 CALL WMENUSETSTATE(ID_COPY,1,0)
 CALL WMENUSETSTATE(ID_DELETE,1,0)

 CALL POLYGON1INIT()

 ICUR_ITREE =0
 ICUR_IFIELD=0

 CALL IR1FILLTREEVIEW()
 CALL IR1FIELDS_MAIN()

 CALL WDIALOGSELECT(ID_DIR_PMTAB1TAB2)
 CALL WDIALOGPUTIMAGE(ID_DRAW,ID_ICONDRAW,1)
 CALL WDIALOGPUTIMAGE(ID_DELETE,ID_ICONDELETE,1)
 CALL WDIALOGPUTIMAGE(ID_LOADSHAPE,ID_ICONOPEN,1)
 CALL WDIALOGPUTIMAGE(ID_SAVESHAPE,ID_ICONSAVE,1)
 CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1)
 CALL WDIALOGPUTIMAGE(ID_GENCOPY,ID_ICONPOLYGONPLUS,I)

 IF(MAXMES.LT.NIR)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Maximal '//TRIM(ITOS(MAXMES))//' measures can be supported by the QS Tool',&
  'Error')
  CALL IR1CLOSE(0)
  RETURN
 ENDIF

 CALL WDIALOGSELECT(ID_DIR_PMTAB2TAB2)
 CALL WDIALOGPUTIMAGE(ID_DRAW,ID_ICONDRAW,1)
 CALL WDIALOGPUTIMAGE(ID_DELETE,ID_ICONDELETE,1)
 CALL WDIALOGPUTIMAGE(ID_LOADSHAPE,ID_ICONOPEN,1)
 CALL WDIALOGPUTIMAGE(ID_SAVESHAPE,ID_ICONSAVE,1)
 CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1)
 CALL WDIALOGPUTIMAGE(ID_GENCOPY,ID_ICONPOLYGONPLUS,I)

 I=0
 IF(NBC.GT.0)I=1
 CALL WDIALOGSELECT(ID_DIR_PMTAB1TAB2)
 CALL WDIALOGFIELDSTATE(ID_GENCOPY,I)
 CALL WDIALOGSELECT(ID_DIR_PMTAB2TAB2)
 CALL WDIALOGFIELDSTATE(ID_GENCOPY,I)

 CALL WDIALOGSELECT(ID_DIR_PMTAB2)
 CALL WDIALOGPUTMENU(IDF_MENU2,ADJUSTL(IR%NAMEIR),NIR,1)

 CALL WDIALOGSELECT(ID_DIR_PMTAB2TAB3)
 CALL WDIALOGPUTMENU(IDF_MENU1,PERRES,NPER*NRES,1)
 CALL WDIALOGPUTIMAGE(ID_APPLY,ID_ICONCALC,1)

 CALL IR1FIELDS_PLOTLABELUNIT()

 IF(NTARGET.EQ.0)THEN
  IF(.NOT.IR1NEW(ID_NEWTARGET,3))THEN
  ENDIF !## hide cancel-button
 ENDIF

 CALL WINDOWSELECT(IRWIN)
 IF(NBC.GT.0)THEN
  CALL WMENUSETSTATE(ID_VIEW,1,1)
  DO IBC=1,NBC
   CALL WMENUSETSTATE(IDV(IBC),1,1)
   CALL WMENUSETSTATE(IDV(IBC),2,1)
   I=INDEX(BC(IBC)%BCNAME,'\',.TRUE.)+1
   CALL WMENUSETSTRING(IDV(IBC),'Show '//TRIM(BC(IBC)%BCNAME(I:)))
  END DO
  DO IBC=NBC+1,MAXDV
   CALL WMENUITEMDELETE(IDV(IBC))
  ENDDO
 ELSE
  CALL WMENUSETSTATE(ID_VIEW,1,0)
 ENDIF
 IF(LEN_TRIM(PRJFNAME).EQ.0)CALL WMENUSETSTATE(ID_SAVE,1,0)

 !## draw polygons - force redraw drawing (incl. gen-polygons)
 CALL IDFPLOT(1)

 LPLOTYSEL=.FALSE.

 END SUBROUTINE IR1INIT

 !###======================================================================
 SUBROUTINE IR1RENAME()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: ITREE,IFIELD,ITYPE
 CHARACTER(LEN=MAXLEN) :: CNAME
 TYPE(WIN_MESSAGE) :: MESSAGE

 !## get level of treeview
 CALL IR1GETTREEVIEWID(ITREE,IFIELD)

 CALL WDIALOGLOAD(ID_POLYGONSHAPENAME,ID_POLYGONSHAPENAME)
 CALL WDIALOGFIELDSTATE(IDHELP,3)

 SELECT CASE (ITREE)
  !## targets
  CASE (1)
   CNAME=TTREE(IFIELD)%CNAME
  !## measures
  CASE (2)
   CNAME=MTREE(IFIELD)%CNAME
  !## results
  CASE (3)
   CNAME=RTREE(IFIELD)%CNAME
 END SELECT

 CALL WDIALOGPUTSTRING(IDF_STRING1,CNAME)
 CALL WDIALOGSHOW(-1,-1,0,3)

 DO
  CALL WMESSAGE(ITYPE,MESSAGE)
  IF(ITYPE.EQ.PUSHBUTTON)THEN
   IF(MESSAGE%VALUE1.EQ.IDOK)CALL WDIALOGGETSTRING(IDF_STRING1,CNAME)
   EXIT
  ENDIF
 ENDDO

 CALL WDIALOGUNLOAD()

 CALL WDIALOGSELECT(ID_DIR_PM)

 IF(MESSAGE%VALUE1.EQ.IDOK)THEN
  SELECT CASE (ITREE)
   !## targets
   CASE (1)
    TTREE(IFIELD)%CNAME=CNAME
    CALL WDIALOGSETTREEVIEWSTRING(IDF_TREEVIEW1,TTREE(IFIELD)%TARGET_ID,TRIM(CNAME))
   !## measures
   CASE (2)
    MTREE(IFIELD)%CNAME=CNAME
    CALL WDIALOGSETTREEVIEWSTRING(IDF_TREEVIEW1,MTREE(IFIELD)%MEASURE_ID,TRIM(CNAME))
   !## results --- ook hernoemen van de directory ...
   CASE (3)
    RTREE(IFIELD)%CNAME=CNAME
    CALL WDIALOGSETTREEVIEWSTRING(IDF_TREEVIEW1,RTREE(IFIELD)%RESULT_ID,TRIM(CNAME))
  END SELECT

 ENDIF

 END SUBROUTINE IR1RENAME

 !###======================================================================
 SUBROUTINE IR1FILLTREEVIEW()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: IPOS,ITARGET,IMEASURE,IRESULT

 !## fill menu - if available
 CALL WDIALOGSELECT(ID_DIR_PM)
 IF(NTARGET.EQ.0)THEN
  CALL WDIALOGCLEARFIELD(IDF_TREEVIEW1)
 ELSE
  CALL WDIALOGCLEARFIELD(IDF_TREEVIEW1)
  DO ITARGET=1,NTARGET
   IPOS=INSERTAFTER
!WRITE(*,*) TTREE(ITARGET)%IDPOS,IPOS,TTREE(ITARGET)%TARGET_ID,TRIM(TTREE(ITARGET)%CNAME)
!WDIALOGINSERTTREEVIEWITEM(IDF_TREEVIEW1,IDPOS,IPOS,IDITEM,TRIM(CNAME))!/
   CALL WDIALOGINSERTTREEVIEWITEM(IDF_TREEVIEW1,TTREE(ITARGET)%IDPOS,IPOS,TTREE(ITARGET)%TARGET_ID,TRIM(TTREE(ITARGET)%CNAME)) !// &
!    ' '//TRIM(itos(TTREE(ITARGET)%IDPOS))//';'//TRIM(itos(TTREE(ITARGET)%TARGET_ID)))
!   !//' IDPOS:'//TRIM(ITOS(IDPOS))//';_ID:'//TRIM(ITOS(IDITEM)))
   CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,TTREE(ITARGET)%TARGET_ID)
   IPOS=INSERTCHILD
   DO IMEASURE=1,NMEASURE
    IF(MTREE(IMEASURE)%IDPOS.EQ.TTREE(ITARGET)%TARGET_ID)THEN
     CALL WDIALOGINSERTTREEVIEWITEM(IDF_TREEVIEW1,MTREE(IMEASURE)%IDPOS,IPOS,MTREE(IMEASURE)%MEASURE_ID, &
      TRIM(MTREE(IMEASURE)%CNAME)) !//&!)
     CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,MTREE(IMEASURE)%MEASURE_ID)
!    ' '//TRIM(itos(mTREE(Imeasure)%IDPOS))//';'//TRIM(itos(mTREE(Imeasure)%measure_ID)))
     DO IRESULT=1,NRESULT
      IF(RTREE(IRESULT)%IDPOS.EQ.MTREE(IMEASURE)%MEASURE_ID)THEN
       CALL WDIALOGINSERTTREEVIEWITEM(IDF_TREEVIEW1,RTREE(IRESULT)%IDPOS,IPOS,RTREE(IRESULT)%RESULT_ID,TRIM(RTREE(IRESULT)%CNAME))
       CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,RTREE(IRESULT)%RESULT_ID)
      ENDIF
     END DO
    ENDIF
   END DO
  END DO
 ENDIF
 CALL WDIALOGPUTTREEVIEW(IDF_TREEVIEW1,TTREE(1)%TARGET_ID)

 END SUBROUTINE IR1FILLTREEVIEW

 !###======================================================================
 SUBROUTINE IR1CLOSE(ICODE)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ICODE
 INTEGER :: ID

 IF(ICODE.EQ.1)THEN
  IF(LEN_TRIM(PRJFNAME).EQ.0)CALL WMESSAGEBOX(YESNOCANCEL,QUESTIONICON,COMMONNO,'Do you want to save your work?','Question')
  IF(LEN_TRIM(PRJFNAME).NE.0)CALL WMESSAGEBOX(YESNOCANCEL,QUESTIONICON,COMMONNO,'Do you want to save your work to'//CHAR(13)// &
   TRIM(PRJFNAME)//' ?','Question')
  IF(WINFODIALOG(4).EQ.0)THEN
   IDIAGERROR=1
   RETURN
  ENDIF
  IF(WINFODIALOG(4).EQ.1)THEN
   ID=ID_SAVE
   IF(LEN_TRIM(PRJFNAME).EQ.0)ID=ID_SAVEAS
   IF(.NOT.IR1PRJFILES(ID))THEN
   ENDIF
  ENDIF
 ENDIF

 IF(IRWIN.NE.0)THEN
  CALL WINDOWCLOSECHILD(IRWIN)
  CALL WDIALOGSELECT(ID_DIRMEASURES)
  CALL WDIALOGUNLOAD()
  CALL WDIALOGSELECT(ID_DIRTARGETS)
  CALL WDIALOGUNLOAD()
 ENDIF

 IRWIN=0

 !##draw previous filled shape
! CALL IR1DRAWSHAPES()

! CALL POLYGON1DRAWSHAPE(1,SHPNO)
 CALL POLYGON1CLOSE()

 CALL IR1DEALLOCATE()

 LPLOTYSEL=.FALSE.

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

 CALL IDFPLOT(1)

 END SUBROUTINE IR1CLOSE

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

 CALL IR1DEALLOCATE_TREE()

 IF(ALLOCATED(RES))DEALLOCATE(RES)
 IF(ALLOCATED(PER))DEALLOCATE(PER)
 IF(ALLOCATED(PERRES))DEALLOCATE(PERRES)

 IF(ALLOCATED(BC))THEN
  DO I=1,NBC
   IF(ASSOCIATED(BC(I)%X))   DEALLOCATE(BC(I)%X)
   IF(ASSOCIATED(BC(I)%Y))   DEALLOCATE(BC(I)%Y)
   IF(ASSOCIATED(BC(I)%IXY)) DEALLOCATE(BC(I)%IXY)
   IF(ASSOCIATED(BC(I)%XMIN))DEALLOCATE(BC(I)%XMIN)
   IF(ASSOCIATED(BC(I)%XMAX))DEALLOCATE(BC(I)%XMAX)
   IF(ASSOCIATED(BC(I)%YMIN))DEALLOCATE(BC(I)%YMIN)
   IF(ASSOCIATED(BC(I)%YMAX))DEALLOCATE(BC(I)%YMAX)
  ENDDO
  DEALLOCATE(BC)
 ENDIF

 CALL IR1FIELDS_DEALLOCATE()

 CALL UTL_CLOSEUNITS()

 END SUBROUTINE IR1DEALLOCATE

 !###======================================================================
 SUBROUTINE IR1COPY_TARGET(IFIELD,IPOL1,IPOL2)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IFIELD
 INTEGER,INTENT(IN) :: IPOL1  !## copy information from polygon
 INTEGER,INTENT(IN) :: IPOL2  !## copy information to polygon

! TTREE(IFIELD)%POL(IPOL2)%EFFECT       =TTREE(IFIELD)%POL(IPOL1)%EFFECT
 IF(ASSOCIATED(TTREE(IFIELD)%POL(IPOL1)%DEF).AND. &
    ASSOCIATED(TTREE(IFIELD)%POL(IPOL2)%DEF))THEN
  TTREE(IFIELD)%POL(IPOL2)%DEF(1:MAXDEF)=TTREE(IFIELD)%POL(IPOL1)%DEF(1:MAXDEF)
 ENDIF

 END SUBROUTINE IR1COPY_TARGET

 !###======================================================================
 SUBROUTINE IR1COPY_MEASURE(IFIELD,IPOL1,IPOL2)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IFIELD
 INTEGER,INTENT(IN) :: IPOL1  !## copy information from polygon
 INTEGER,INTENT(IN) :: IPOL2  !## copy information to polygon

 IF(ASSOCIATED(MTREE(IFIELD)%POL(IPOL1)%MES).AND. &
    ASSOCIATED(MTREE(IFIELD)%POL(IPOL2)%MES))THEN
  MTREE(IFIELD)%POL(IPOL2)%MES(1:MAXMES)=MTREE(IFIELD)%POL(IPOL1)%MES(1:MAXMES)
 ENDIF

 END SUBROUTINE IR1COPY_MEASURE

 !###======================================================================
 FUNCTION IR1INITFILES()
 !###======================================================================
 IMPLICIT NONE
 LOGICAL :: IR1INITFILES
 INTEGER :: I,J,K,IOS,IU,IBC
 LOGICAL :: LEX
 CHARACTER(LEN=256) :: LINE

 IR1INITFILES=.FALSE.

 IF(TRIM(PREFVAL(6)).EQ.'')THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot initiate IR-tool since the variable IRDBASE '//CHAR(13)// &
    'is not loaded from the currently selected *.prf file!','Error')
  RETURN
 ENDIF

 INQUIRE(FILE=PREFVAL(6),EXIST=LEX)
 IF(.NOT.LEX)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot initiate IR-tool since file: '//CHAR(13)// &
    TRIM(PREFVAL(6))//CHAR(13)//'does not exists !','Error')
  RETURN
 ENDIF

 IU=UTL_GETUNIT()
 CALL OSD_OPEN(IU,FILE=TRIM(PREFVAL(6)),ACCESS='SEQUENTIAL',FORM='FORMATTED',ACTION='READ,DENYWRITE',IOSTAT=IOS)
 IF(IOS.NE.0)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot open [ '// &
       TRIM(PREFVAL(6))//' ] for reading!','Error')
  RETURN
 ENDIF

 !## result directory
 MAINRESDIR=TRIM(PREFVAL(1))//'\QSRESULTS'
 CALL UTL_CREATEDIR(TRIM(PREFVAL(1))//'\QSRESULTS')

 IF(.NOT.UTL_READINITFILE(UTL_CAP('QUARTERRUN','U'),LINE,IU,0))RETURN
 READ(LINE,*) QUARTERRUNFILE
 IF(.NOT.UTL_READINITFILE(UTL_CAP('BASISRUN','U'),LINE,IU,0))RETURN
 READ(LINE,*) BASISRUNFILE
 IF(.NOT.UTL_READINITFILE(UTL_CAP('TARGETLEG','U'),LINE,IU,0))RETURN
 READ(LINE,*) TARGETLEG

 !## number of ir-directories
 IF(.NOT.UTL_READINITFILE(UTL_CAP('NIR','U'),LINE,IU,0))RETURN
 READ(LINE,*) NIR

 IF(ALLOCATED(IR))DEALLOCATE(IR)
 ALLOCATE(IR(NIR))

 DO I=1,NIR

  IF(.NOT.UTL_READINITFILE(UTL_CAP('DIRIR'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) IR(I)%DIRIR
  IF(.NOT.UTL_READINITFILE(UTL_CAP('NAMEIR'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) IR(I)%NAMEIR
  IF(.NOT.UTL_READINITFILE(UTL_CAP('MINIR'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) IR(I)%MINIR
  IF(.NOT.UTL_READINITFILE(UTL_CAP('MAXIR'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) IR(I)%MAXIR
  IF(.NOT.UTL_READINITFILE(UTL_CAP('IDFIR'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) IR(I)%IDFIR
  IF(.NOT.UTL_READINITFILE(UTL_CAP('TYPEIR'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) IR(I)%TYPEIR
  IF(.NOT.UTL_READINITFILE(UTL_CAP('SDFIR'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) IR(I)%SDFIR
  IF(.NOT.UTL_READINITFILE(UTL_CAP('SDFBM'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) IR(I)%SDFBM
 END DO

 !## number of period-definitions
 IF(.NOT.UTL_READINITFILE(UTL_CAP('NPER','U'),LINE,IU,0))RETURN
 READ(LINE,*) NPER

 ALLOCATE(PER(NPER))

 DO I=1,NPER
  IF(.NOT.UTL_READINITFILE(UTL_CAP('NAMEPER'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) PER(I)%NAMEPER
  IF(.NOT.UTL_READINITFILE(UTL_CAP('IPERPER'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) PER(I)%IPERPER
 END DO

 !## number of result-definitions
 IF(.NOT.UTL_READINITFILE(UTL_CAP('NRES','U'),LINE,IU,0))RETURN
 READ(LINE,*) NRES

 ALLOCATE(RES(NRES))

 DO I=1,NRES
  IF(.NOT.UTL_READINITFILE(UTL_CAP('NAMERES'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) RES(I)%NAMERES
  IF(INDEX(RES(I)%NAMERES,CHAR(92)).GT.0)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Do not use the character "\" in the name of an IR-result!','Error')
   RETURN
  ENDIF
  IF(.NOT.UTL_READINITFILE(UTL_CAP('DIRRES'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) RES(I)%DIRRES
  IF(.NOT.UTL_READINITFILE(UTL_CAP('ILAYRES'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) RES(I)%ILAYRES
  IF(.NOT.UTL_READINITFILE(UTL_CAP('ITYPERES'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) RES(I)%ITYPERES
  IF(RES(I)%ITYPERES.LT.0.OR.RES(I)%ITYPERES.GT.1)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'ITYPERES should be between 0 and 1!','Error')
   RETURN
  ENDIF
  IF(.NOT.UTL_READINITFILE(UTL_CAP('LEGRES'//TRIM(ITOS(I)),'U'),LINE,IU,0))RETURN
  READ(LINE,*) RES(I)%LEGRES
 END DO

 ALLOCATE(PERRES(NRES*NPER))

 K=0
 DO I=1,NPER
  DO J=1,NRES
   K=K+1
   PERRES(K)=TRIM(PER(I)%NAMEPER)//'-'//TRIM(RES(J)%NAMERES)
  END DO
 END DO

 !## number of background coverages
 IF(.NOT.UTL_READINITFILE(UTL_CAP('NBC','U'),LINE,IU,0))RETURN
 READ(LINE,*) NBC

 IF(NBC.GT.MAXDV)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Number of background cover is restricted to '//TRIM(ITOS(MAXDV)),'Error')
  RETURN
 ENDIF

 ALLOCATE(BC(NBC))

 !## read (optional) gen file for selecting purposes
 DO IBC=1,NBC
  IF(.NOT.UTL_READINITFILE(UTL_CAP('BC'//TRIM(ITOS(IBC)),'U'),LINE,IU,1))RETURN
  CALL IR1GENREAD(IBC,LINE)
 END DO

 CLOSE(IU)

 IR1INITFILES=.TRUE.

 END FUNCTION IR1INITFILES

END MODULE MOD_IR