!!  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_IPF

USE WINTERACTER
USE RESOURCE
USE MODPLOT
USE IMODVAR, ONLY : IBACKSLASH,ILABELNAME
USE MOD_UTL, ONLY : UTL_GETUNIT,ITOS,UTL_CAP,RTOS,UTL_WAITMESSAGE,INVERSECOLOUR,UTL_SETTEXTSIZE, &
          UTL_FILLARRAY,UTL_IDFGETCLASS,UTL_DIRINFO,UTL_GETUNIQUE_INT,UTL_DIRINFO_POINTER,UTL_SUBST, &
          UTL_CREATEDIR
USE MOD_PROFILE_UTL, ONLY : GRAPHUNITS 
USE MOD_IPF_PAR
USE MOD_IPFASSFILE, ONLY : IPFINITASSFILE,IPFPLOTASSFILE,IPFCLOSEASSFILE,IPFDIMENSIONASSFILE,ASSF,IPFASSFILEALLOCATE
USE MOD_IPFGETVALUE_COLOURS, ONLY : IPFGETVALUE_GETCOLOURS
USE MOD_COLOURS
USE MOD_OSD, ONLY : OSD_OPEN
USE MOD_IDF, ONLY : IDFREAD,IDFDEALLOCATE,IDFGETXYVAL,IDFNULLIFY,IDFREADSCALE,IDFCOPY,IDFIROWICOL,IDFDEALLOCATEX,IDFALLOCATEX,IDFWRITE
USE MOD_IDF_PAR, ONLY : IDFOBJ
USE MOD_QKSORT

INTEGER,PARAMETER,PRIVATE :: TFONT=FFHELVETICA

TYPE(WIN_MESSAGE),PRIVATE :: MESSAGE
INTEGER,PRIVATE :: ITYPE
REAL,PRIVATE,PARAMETER :: XSIZE=100.0     !## size of cross for selected ipf's

CONTAINS

 !###======================================================================
 SUBROUTINE IPFSAMPLE(IPFNAME1,IPFNAME2,IDFNAME,IXCOL,IYCOL,IACOL)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: IPFNAME1,IPFNAME2,IDFNAME
 INTEGER,INTENT(IN) :: IXCOL,IYCOL,IACOL
 TYPE(IDFOBJ),DIMENSION(:),ALLOCATABLE :: IDF
 CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: IDFNAMES
 CHARACTER(LEN=50) :: WC 
 CHARACTER(LEN=256) :: ROOT
 INTEGER :: I,J,JJ,N
 REAL :: X
 
 I=INDEX(IDFNAME,'\',.TRUE.); ROOT=IDFNAME(:I-1); WC=TRIM(IDFNAME(I+1:))
 CALL IOSDIRENTRYTYPE('F'); CALL IOSDIRCOUNT(TRIM(ROOT),TRIM(WC),N)
 IF(N.EQ.0)THEN; WRITE(*,*) 'No files found in: '//TRIM(IDFNAME); RETURN; ENDIF
 ALLOCATE(IDFNAMES(N))
 CALL UTL_DIRINFO(TRIM(ROOT),TRIM(WC),IDFNAMES,N,'F')
 DO I=1,SIZE(IDFNAMES); IDFNAMES(I)=TRIM(ROOT)//'\'//TRIM(IDFNAMES(I)); ENDDO
 
 NIPF=1
 CALL IPFALLOCATE()
 IPF(1)%XCOL =IXCOL !## x
 IPF(1)%YCOL =IYCOL !## y
 IPF(1)%ZCOL =IXCOL !## z not used
 IPF(1)%Z2COL=IXCOL !## z2 not used
 IPF(1)%QCOL =IXCOL !## q not used
 
 ALLOCATE(IDF(N))
 DO I=1,N; CALL IDFNULLIFY(IDF(I)); ENDDO
 DO I=1,N; IF(IDFREAD(IDF(I),IDFNAMES(I),0))THEN; ENDIF; ENDDO
 IF(I.GT.N)THEN
  
  IPF(1)%FNAME=IPFNAME1
  !# read entire ipf
  IF(IPFREAD2(1,1,1))THEN

   !## create extra header
   ALLOCATE(IPF(1)%DUMMY_ATTRIB(IPF(1)%NCOL+N))
   DO J=1,IPF(1)%NCOL; IPF(1)%DUMMY_ATTRIB(J)=IPF(1)%ATTRIB(J); ENDDO
   DEALLOCATE(IPF(1)%ATTRIB)
   IPF(1)%ATTRIB=>IPF(1)%DUMMY_ATTRIB
   
   !## add to the end
   IF(IACOL.EQ.0)THEN
    !## add extra header with idffile name
    DO J=1,N
     IPF(1)%ATTRIB(IPF(1)%NCOL+J)=TRIM(IDF(J)%FNAME(INDEX(IDF(J)%FNAME,'\',.TRUE.)+1:))
    ENDDO
   ELSE
    DO J=IPF(1)%NCOL+N,IACOL+N,-1
     IPF(1)%ATTRIB(J)=IPF(1)%ATTRIB(J-N)
    ENDDO
    JJ=0
    DO J=IACOL,IACOL+N-1
     JJ=JJ+1
     IPF(1)%ATTRIB(J)=TRIM(IDF(JJ)%FNAME(INDEX(IDF(JJ)%FNAME,'\',.TRUE.)+1:))
    ENDDO
      
   ENDIF 
   
   !## create extra record to store reading of idf-file
   ALLOCATE(IPF(1)%DUMMY_INFO(IPF(1)%NCOL+N,IPF(1)%NROW))
   DO J=1,IPF(1)%NCOL
    DO JJ=1,IPF(1)%NROW
     IPF(1)%DUMMY_INFO(J,JJ)=IPF(1)%INFO(J,JJ)
    ENDDO
   ENDDO
!   IPF(1)%DUMMY_INFO(1:IPF(1)%NCOL,:)=IPF(1)%INFO(1:IPF(1)%NCOL,:)
   DEALLOCATE(IPF(1)%INFO)
   IPF(1)%INFO=>IPF(1)%DUMMY_INFO
   
   !## shift data
   IF(IACOL.GT.0)THEN
    !## add extra header with idffile name
    DO J=IPF(1)%NCOL+N,IACOL+N,-1
     DO JJ=1,IPF(1)%NROW
      IPF(1)%INFO(J,JJ)=IPF(1)%INFO(J-N,JJ)
     ENDDO
    ENDDO
   ENDIF
   
   DO I=1,IPF(1)%NROW
    DO J=1,N
     X=IDFGETXYVAL(IDF(J),IPF(1)%XYZ(1,I),IPF(1)%XYZ(2,I))
     IF(IACOL.EQ.0)THEN
      IPF(1)%INFO(IPF(1)%NCOL+J,I)=TRIM(RTOS(X,'F',7))
     ELSE
      IPF(1)%INFO(IACOL+J-1,I)=TRIM(RTOS(X,'F',7))
     ENDIF
    ENDDO
   ENDDO
   
   !## write new ipf
   IPF(1)%FNAME=IPFNAME2
   IPF(1)%NCOL=IPF(1)%NCOL+N
   !## create folder
!   write(*,*) IPF(1)%FNAME(:INDEX(IPF(1)%FNAME,'\',.TRUE.)-1)
   CALL UTL_CREATEDIR(IPF(1)%FNAME(:INDEX(IPF(1)%FNAME,'\',.TRUE.)-1))
   
   IF(.NOT.IPFWRITE(1))THEN
   ENDIF

  ENDIF
 ENDIF
 
 CALL IPFDEALLOCATE()
 CALL IDFDEALLOCATE(IDF,SIZE(IDF))
 
 END SUBROUTINE IPFSAMPLE
 
 !###======================================================================
 SUBROUTINE IPFSPOTIFY(IPFNAME,TOPIDF,BOTIDF,IXCOL,REGIS,OUTPUTFOLDER)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: IPFNAME,REGIS
 CHARACTER(LEN=*),INTENT(IN) :: OUTPUTFOLDER
 INTEGER,INTENT(IN),DIMENSION(:) :: IXCOL
 TYPE(IDFOBJ),DIMENSION(:),INTENT(INOUT) :: TOPIDF,BOTIDF
 CHARACTER(LEN=256),POINTER,DIMENSION(:) :: IDFNAMES
 TYPE(IDFOBJ),DIMENSION(:),ALLOCATABLE :: TBIDF,FMDL
 CHARACTER(LEN=52) :: WC
 CHARACTER(LEN=52),DIMENSION(:),ALLOCATABLE :: CTYPE
 CHARACTER(LEN=256) :: ROOT
 INTEGER :: I,J,K,N,ILAY,IROW,ICOL
 INTEGER,DIMENSION(:),ALLOCATABLE :: NTYPE
 REAL :: X,T,B,TM,BM,TF,BF
 LOGICAL :: LIPF
 
 LIPF=.FALSE.; IF(IPFNAME(1).NE.'')LIPF=.TRUE.
 
 !## get list of "regis"-files
 I=INDEX(REGIS(1),'\',.TRUE.); ROOT=REGIS(1)(:I-1); WC=UTL_CAP(TRIM(REGIS(1)(I+1:)),'U')
 IF(.NOT.UTL_DIRINFO_POINTER(ROOT,WC,IDFNAMES,'F'))RETURN

 DO I=1,SIZE(TOPIDF); IF(IDFREAD(TOPIDF(I),TOPIDF(I)%FNAME,1))THEN; ENDIF; ENDDO
 DO I=1,SIZE(BOTIDF); IF(IDFREAD(BOTIDF(I),BOTIDF(I)%FNAME,1))THEN; ENDIF; ENDDO
 
 ALLOCATE(TBIDF(2)); DO I=1,SIZE(TBIDF); CALL IDFNULLIFY(TBIDF(I)); ENDDO
 CALL IDFCOPY(TOPIDF(1),TBIDF(1));CALL IDFCOPY(TOPIDF(1),TBIDF(2))

 IF(LIPF)THEN
  NIPF=1; CALL IPFALLOCATE()
  IPF(1)%XCOL =IXCOL(1) !## x
  IPF(1)%YCOL =IXCOL(2) !## y
  IPF(1)%QCOL =IXCOL(3) !## q not used
  IPF(1)%ZCOL =IXCOL(4) !## z not used
  IPF(1)%Z2COL=IXCOL(5) !## z2 not used  
  IPF(1)%FNAME=IPFNAME(1)
  !# read entire ipf
  IF(.NOT.IPFREAD2(1,1,1))RETURN
  !## remove lines with zero fraction
  J=0; DO I=1,IPF(1)%NROW
   IF(IPF(1)%XYZ(5,I).GT.0.0)THEN
    J=J+1
    IF(I.NE.J)THEN
     IPF(1)%INFO(:,J)=IPF(1)%INFO(:,I)
     IPF(1)%XYZ(:,J)=IPF(1)%XYZ(:,I) 
    ENDIF
   ENDIF
  ENDDO
  IPF(1)%NROW=J
 ELSE
  ALLOCATE(FMDL(SIZE(TOPIDF))); DO I=1,SIZE(FMDL); CALL IDFNULLIFY(FMDL(I)); ENDDO
  DO I=1,SIZE(FMDL); CALL IDFCOPY(TOPIDF(1),FMDL(I)); IF(.NOT.IDFALLOCATEX(FMDL(I)))RETURN; FMDL(I)%X=0.0; FMDL(I)%NODATA=0.0; ENDDO
 ENDIF
  
 ALLOCATE(CTYPE(SIZE(IDFNAMES)),NTYPE(MAX(SIZE(FMDL),SIZE(IDFNAMES))))
 DO I=1,SIZE(IDFNAMES)
  IDFNAMES(I)=UTL_CAP(TRIM(ROOT)//'\'//TRIM(IDFNAMES(I)),'U')
  J=INDEX(WC,'*'); J=MAX(J,1)
  K=INDEX(IDFNAMES(I),TRIM(WC(J+1:)))-1
  J=INDEX(IDFNAMES(I),'\',.TRUE.)+1; 
  CTYPE(I)=IDFNAMES(I)(J:K); NTYPE(I)=0
 ENDDO 

 IF(LIPF)THEN
  !## create extra header
  N=SIZE(IDFNAMES); ALLOCATE(IPF(1)%DUMMY_ATTRIB(IPF(1)%NCOL+N))
  IPF(1)%DUMMY_ATTRIB(1:IPF(1)%NCOL)=IPF(1)%ATTRIB(1:IPF(1)%NCOL)
  DEALLOCATE(IPF(1)%ATTRIB); IPF(1)%ATTRIB=>IPF(1)%DUMMY_ATTRIB
  !## add extra header with idffile name
  DO J=1,N; IPF(1)%ATTRIB(IPF(1)%NCOL+J)=TRIM(CTYPE(J)); ENDDO  
  !## create extra record to store reading of idf-file
  ALLOCATE(IPF(1)%DUMMY_INFO(IPF(1)%NCOL+N,IPF(1)%NROW))   
  IPF(1)%DUMMY_INFO(1:IPF(1)%NCOL,:)=IPF(1)%INFO(1:IPF(1)%NCOL,:)
  DEALLOCATE(IPF(1)%INFO); IPF(1)%INFO=>IPF(1)%DUMMY_INFO
 ENDIF
 
 N=0; DO I=1,SIZE(IDFNAMES)
  TBIDF(1)%FNAME=IDFNAMES(I)
  J=INDEX(WC,'*'); J=MAX(J,1)
  TBIDF(2)%FNAME=UTL_SUBST(REGIS(2),WC(:J),TRIM(CTYPE(I)))
  WRITE(*,'(/A)') 'Reading data from:'
  WRITE(*,'(A)') '[TOP] - '//TRIM(TBIDF(1)%FNAME)
  IF(.NOT.IDFREADSCALE(TBIDF(1)%FNAME,TBIDF(1),10,0,0.0,0))RETURN
  WRITE(*,'(A)') '[BOT] - '//TRIM(TBIDF(2)%FNAME)
  IF(.NOT.IDFREADSCALE(TBIDF(2)%FNAME,TBIDF(2),10,0,0.0,0))RETURN
  K=0; DO IROW=1,TBIDF(1)%NROW; DO ICOL=1,TBIDF(1)%NCOL
   IF(TBIDF(1)%X(ICOL,IROW)-TBIDF(2)%X(ICOL,IROW).GT.0.0)K=K+1
  ENDDO; ENDDO
  IF(K.EQ.0)THEN; WRITE(*,'(A)') 'Not available in current model dimensions'; CYCLE; ENDIF
   
  IF(LIPF)THEN
   N=N+1; IPF(1)%ATTRIB(N+IPF(1)%NCOL)=IPF(1)%ATTRIB(I+IPF(1)%NCOL)
   !## check whether this formation is used by each row in ipf
   DO J=1,IPF(1)%NROW
    !## fraction > 0.0
    X=0.0
    IF(IPF(1)%XYZ(5,J).GT.0.0)THEN
     READ(IPF(1)%INFO(IXCOL(6),J),*) ILAY
     CALL IDFIROWICOL(TOPIDF(1),IROW,ICOL,IPF(1)%XYZ(1,J),IPF(1)%XYZ(2,J))

     !## top/bottom modellayer
     TM=TOPIDF(ILAY)%X(ICOL,IROW); BM=BOTIDF(ILAY)%X(ICOL,IROW)
     !## skip nodata
     IF(TM.EQ.TOPIDF(ILAY)%NODATA.OR.BM.EQ.BOTIDF(ILAY)%NODATA)CYCLE

     !## top/bottom formation
     T=TBIDF(1)%X(ICOL,IROW); B=TBIDF(2)%X(ICOL,IROW)
     !## skip nodata
     IF(T.EQ.TBIDF(1)%NODATA.OR.B.EQ.TBIDF(2)%NODATA)CYCLE

     IF(T-B.GT.0.0)THEN
      !## top/bottom filters
      TF=IPF(1)%XYZ(3,J)
      BF=IPF(1)%XYZ(4,J)
      TF=MIN(TF,TM)
      BF=MAX(BF,BM)
      T =MIN(TF,T)
      B =MAX(BF,B)
      X =MAX(0.0,(T-B)/(TF-BF))
      IF(X.GT.0.0)NTYPE(I)=NTYPE(I)+1
     ENDIF
    ENDIF
    IPF(1)%INFO(IPF(1)%NCOL+N,J)=TRIM(RTOS(X,'F',7))
   ENDDO
   IF(NTYPE(I).EQ.0)N=N-1
   WRITE(*,'(I10,A)') NTYPE(I),' ntype points found'
  ELSE
   DO J=1,SIZE(FMDL); FMDL(J)%X=0.0; ENDDO 
   NTYPE=0; DO IROW=1,TBIDF(1)%NROW; DO ICOL=1,TBIDF(1)%NCOL; DO ILAY=1,SIZE(FMDL)

    !## top/bottom modellayer
    TM=TOPIDF(ILAY)%X(ICOL,IROW); BM=BOTIDF(ILAY)%X(ICOL,IROW)
    !## skip nodata in model
    IF(TM.EQ.TOPIDF(ILAY)%NODATA.OR.BM.EQ.BOTIDF(ILAY)%NODATA)CYCLE

    !## top/bottom formation
    T=TBIDF(1)%X(ICOL,IROW); B=TBIDF(2)%X(ICOL,IROW)
    !## skip nodata in geology model
    IF(T.EQ.TBIDF(1)%NODATA.OR.B.EQ.TBIDF(2)%NODATA)CYCLE

    T=MIN(TM,T); B=MAX(BM,B); X=MAX(0.0,(T-B)/(TM-BM))

    IF(X.GT.0.0)THEN
     FMDL(ILAY)%X(ICOL,IROW)=X; NTYPE(ILAY)=NTYPE(ILAY)+1
    ENDIF

   ENDDO; ENDDO; ENDDO
   DO J=1,SIZE(NTYPE) !FMDL)
    IF(NTYPE(J).GT.0)THEN
     FMDL(J)%FNAME=TRIM(OUTPUTFOLDER)//'\FRACTIONS_L'//TRIM(ITOS(J))//'\'//TRIM(CTYPE(I))//'.IDF'
     FMDL(J)%NODATA=-999.99
     IF(.NOT.IDFWRITE(FMDL(J),FMDL(J)%FNAME,1))RETURN
    ENDIF
   ENDDO   
  ENDIF
   
  CALL IDFDEALLOCATEX(TBIDF(1)); CALL IDFDEALLOCATEX(TBIDF(2))
 ENDDO 
 
 IF(LIPF)THEN
  !## write new ipf
  IPF(1)%FNAME=IPFNAME(2)
  IPF(1)%NCOL=IPF(1)%NCOL+N
  IF(.NOT.IPFWRITE(1))THEN; ENDIF
  CALL IPFDEALLOCATE()
 ELSE
  CALL IDFDEALLOCATE(FMDL,SIZE(FMDL))
 ENDIF
 CALL IDFDEALLOCATE(TOPIDF,SIZE(TOPIDF))
 CALL IDFDEALLOCATE(BOTIDF,SIZE(BOTIDF))
 CALL IDFDEALLOCATE(TBIDF,SIZE(TBIDF))
 DEALLOCATE(IDFNAMES); DEALLOCATE(CTYPE)

 END SUBROUTINE IPFSPOTIFY
 
 !###======================================================================
 SUBROUTINE IPFASSIGNWELL(IPFNAME,TOPIDF,BOTIDF,IXCOL,IFCOL)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: IPFNAME
 INTEGER,INTENT(IN),DIMENSION(:) :: IXCOL,IFCOL
 TYPE(IDFOBJ),DIMENSION(:),INTENT(INOUT) :: TOPIDF,BOTIDF
 INTEGER :: I,J,K
 REAL :: Z1,Z2,T,B,XC,YC,D
 REAL,ALLOCATABLE,DIMENSION(:) :: F
 
 NIPF=1; CALL IPFALLOCATE()
 IPF(1)%XCOL =IXCOL(1) !## x
 IPF(1)%YCOL =IXCOL(2) !## y
 IPF(1)%QCOL =IXCOL(1) !## q not used
 IPF(1)%ZCOL =IXCOL(4) !## z not used
 IPF(1)%Z2COL=IXCOL(5) !## z2 not used  
 IPF(1)%FNAME=IPFNAME(1)
 !# read entire ipf
 IF(.NOT.IPFREAD2(1,1,1))RETURN
 DO I=1,SIZE(TOPIDF)
  IF(.NOT.IDFREAD(TOPIDF(I),TOPIDF(I)%FNAME,0))RETURN
  IF(.NOT.IDFREAD(BOTIDF(I),BOTIDF(I)%FNAME,0))RETURN
 ENDDO
 
 ALLOCATE(F(SIZE(IFCOL)))
 DO I=1,IPF(1)%NROW
  READ(IPF(1)%INFO(IXCOL(1),I),*) XC
  READ(IPF(1)%INFO(IXCOL(2),I),*) YC
  F=0.0; DO K=1,SIZE(IFCOL)
   READ(IPF(1)%INFO(IFCOL(K),I),*) F(K)
  ENDDO
  IF(SUM(F).GT.0.0)THEN
   F=F/SUM(F)
   Z1=-9999; Z2=9999
   !## get filter inside formations
   DO K=1,SIZE(IFCOL)
    T=IDFGETXYVAL(TOPIDF(K),XC,YC)
    B=IDFGETXYVAL(BOTIDF(K),XC,YC)
    !## remove from geologic formation
    IF(F(K).GT.0.0)THEN
     Z1=MAX(Z1,T); Z2=MIN(Z2,B)
    ENDIF
   ENDDO
   READ(IPF(1)%INFO(IXCOL(4),I),*) T
   READ(IPF(1)%INFO(IXCOL(5),I),*) B
   Z1=MIN(Z1,T); Z2=MAX(Z2,B)
  ELSE
   Z1=-9999; Z2=9999
  ENDIF
!  DO K=1,SIZE(IFCOL)
!   T=IDFGETXYVAL(TOPIDF(K),XC,YC)
!   B=IDFGETXYVAL(BOTIDF(K),XC,YC)
!   IF(F(K).EQ.0.0)THEN
!    IF(Z1.GT.T)Z2=MAX(Z2,T) 
!    IF(Z2.LT.B)Z1=MIN(Z1,B) 
!   !## remove fraction
!   ELSEIF(F(K).LT.1.0)THEN
!    D=T-B
!    D=F(K)*D
!    IF(Z1.GT.T)Z2=MAX(Z2,T-D)
!    IF(Z2.LT.B)Z1=MIN(Z1,B+D)
!   ENDIF
!  ENDDO
  WRITE(IPF(1)%INFO(IXCOL(4),I),*) Z1
  WRITE(IPF(1)%INFO(IXCOL(5),I),*) Z2
 ENDDO
 
 DO I=1,IPF(1)%NROW
  READ(IPF(1)%INFO(IXCOL(4),I),*) Z1
  READ(IPF(1)%INFO(IXCOL(5),I),*) Z2  
  DO J=I+1,IPF(1)%NROW
   IF(TRIM(IPF(1)%INFO(IXCOL(3),I)).EQ.TRIM(IPF(1)%INFO(IXCOL(3),J)))THEN
    READ(IPF(1)%INFO(IXCOL(4),J),*) T
    READ(IPF(1)%INFO(IXCOL(5),J),*) B
    Z1=MAX(Z1,T)
    Z2=MIN(Z2,B)
    IPF(1)%INFO(1,J)='-999.99'
!    DO K=1,SIZE(IFCOL)
!     IPF(1)%INFO(IFCOL(K),I)=IPF(1)%INFO(IFCOL(K),J)
!     IPF(1)%INFO(IFCOL(K),J)='0'
!    ENDDO
   ENDIF
  ENDDO
  WRITE(IPF(1)%INFO(IXCOL(4),I),*) Z1
  WRITE(IPF(1)%INFO(IXCOL(5),I),*) Z2
 ENDDO
 
 J=0; DO I=1,IPF(1)%NROW
  IF(TRIM(IPF(1)%INFO(1,I)).NE.'-999.99')THEN
   J=J+1
   IF(I.NE.J)THEN
    IPF(1)%INFO(:,J)=IPF(1)%INFO(:,I)
    IPF(1)%XYZ(:,J)=IPF(1)%XYZ(:,I) 
   ENDIF
  ENDIF
 ENDDO
 IPF(1)%NROW=J
 DO I=1,IPF(1)%NROW
  DO J=1,5; IPF(1)%INFO(J,I)=IPF(1)%INFO(IXCOL(J),I); ENDDO
 ENDDO
 DO I=1,5; IPF(1)%ATTRIB(I)=IPF(1)%ATTRIB(IXCOL(I)); ENDDO
 IPF(1)%NCOL=5
 
 !## write new ipf
 IPF(1)%FNAME=IPFNAME(2)
 IF(.NOT.IPFWRITE(1))THEN; ENDIF
 CALL IPFDEALLOCATE()

 END SUBROUTINE IPFASSIGNWELL
 
 !###======================================================================
 SUBROUTINE IPFDRAW()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: IPLOT,IIPF

 !## allocate memory for ipf-plotting, they will be read in memory and drawn from that
 !## if not active, memory will be released
 CALL IPFINIT()

 !## nothing to do
 IF(NIPF.LE.0)RETURN

 IIPF=0
 DO IPLOT=1,MXMPLOT
  IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.2)THEN
   IIPF=IIPF+1

   CALL WINDOWSELECT(0)

   !## check whether information for current ipf is already in memory
   IF(UTL_CAP(IPF(IIPF)%FNAME,'U').EQ.UTL_CAP(MP(IPLOT)%IDFNAME,'U'))THEN
    CALL WINDOWOUTSTATUSBAR(3,'RF Memory ...')
   ELSE
    CALL WINDOWOUTSTATUSBAR(3,'RF Disc ...')
    IF(.NOT.IPFREAD(IPLOT,IIPF))THEN
     CALL IPFDEALLOCATE()
     CALL WINDOWOUTSTATUSBAR(3,'')
     RETURN
    ENDIF
   ENDIF

   IF(MP(IPLOT)%ASSFILES(1).GT.0)THEN
    IF(MP(IPLOT)%ASSFILES(2).LE.0)THEN
     IPF(IIPF)%IPOS=INT(1,1)
     IPF(IIPF)%IP  =INT(MP(IPLOT)%ASSFILES(1),1)
    ELSEIF(MP(IPLOT)%ASSFILES(2).GT.0)THEN
     IPF(IIPF)%IPOS=INT(0,1)
     IPF(IIPF)%IP  =INT(0,1)
     IPF(IIPF)%IPOS(MP(IPLOT)%ASSFILES(2))=INT(1,1)
     IPF(IIPF)%IP(MP(IPLOT)%ASSFILES(2))  =INT(MP(IPLOT)%ASSFILES(1),1)
    ENDIF
   ENDIF
   
   CALL IGRAREA(0.0,0.0,1.0,1.0)
   CALL IGRUNITS(MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX)
   CALL IPFPLOT(IIPF,MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX,IPLOT,(/0.0,0.0,0.0,0.0/),0.0,.TRUE.)

   DRWLIST(IPLOT)=1

  ENDIF
 END DO

 END SUBROUTINE IPFDRAW

 !###======================================================================
 SUBROUTINE IPFINIT()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: IPLOT

 NIPF=0
 DO IPLOT=1,MXMPLOT
  IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.2)THEN
   NIPF=NIPF+1
  ENDIF
 ENDDO

 CALL IPFALLOCATE()

 END SUBROUTINE IPFINIT

 !###======================================================================
 SUBROUTINE IPFALLOCATE()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I
 LOGICAL :: LEX
 
 !## nothing selected to draw, release memory (if available)
 IF(NIPF.LE.0)THEN
  IF(ALLOCATED(IPF))CALL IPFDEALLOCATE()
 ELSE
  LEX=.FALSE.
  IF(ALLOCATED(IPF))THEN
   IF(SIZE(IPF).LT.NIPF)THEN
    !## copy nipf since it is set to zero in ipfdeallocate
    I=NIPF
    CALL IPFDEALLOCATE()
    NIPF=I
    ALLOCATE(IPF(NIPF))
    !## clean names, for security that the file will be read again!
    IPF%FNAME=''
    LEX=.TRUE.
   ELSE
    !## release extra memory
    DO I=NIPF+1,SIZE(IPF)
     CALL IPFDEALLOCATEIIPF(I)
     IF(IPF(I)%IU.GT.0)THEN
      INQUIRE(UNIT=IPF(I)%IU,OPENED=LEX)
      IF(LEX)CLOSE(IPF(I)%IU)
     ENDIF
     IPF(I)%IU=0
    END DO
   ENDIF
  ELSE
   ALLOCATE(IPF(NIPF))
   LEX=.TRUE.
  ENDIF
  
  IF(LEX)THEN
   DO I=1,NIPF
    NULLIFY(IPF(I)%ATTRIB)
    NULLIFY(IPF(I)%IP)
    NULLIFY(IPF(I)%INFO)
    NULLIFY(IPF(I)%XYZ)
    NULLIFY(IPF(I)%XYPOS)
    NULLIFY(IPF(I)%IPOS)
   ENDDO
  ENDIF
  
 ENDIF

 END SUBROUTINE IPFALLOCATE

 !###======================================================================
 SUBROUTINE IPFDEALLOCATE()
 !###======================================================================
 IMPLICIT NONE
 INTEGER :: I
 LOGICAL :: LEX

 IF(.NOT.ALLOCATED(IPF))THEN
  NIPF=0; RETURN
 ENDIF
 
 DO I=1,SIZE(IPF)
  CALL IPFDEALLOCATEIIPF(I)
  IF(IPF(I)%IU.GT.0)THEN
   INQUIRE(UNIT=IPF(I)%IU,OPENED=LEX)
   IF(LEX)CLOSE(IPF(I)%IU)
  ENDIF
  IPF(I)%IU=0
 END DO
 DEALLOCATE(IPF)
 NIPF=0

 END SUBROUTINE IPFDEALLOCATE

 !###======================================================================
 SUBROUTINE IPFDEALLOCATEIIPF(IIPF)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IIPF

 !## clean memory
 IF(ASSOCIATED(IPF(IIPF)%ATTRIB))THEN
  DEALLOCATE(IPF(IIPF)%ATTRIB)
  NULLIFY(IPF(IIPF)%ATTRIB)
 ENDIF
 IF(ASSOCIATED(IPF(IIPF)%IP))THEN
  DEALLOCATE(IPF(IIPF)%IP)
  NULLIFY(IPF(IIPF)%IP)
 ENDIF
 IF(ASSOCIATED(IPF(IIPF)%INFO))THEN
  DEALLOCATE(IPF(IIPF)%INFO)
  NULLIFY(IPF(IIPF)%INFO)
 ENDIF
 IF(ASSOCIATED(IPF(IIPF)%XYZ))THEN
  DEALLOCATE(IPF(IIPF)%XYZ)
  NULLIFY(IPF(IIPF)%XYZ)
 ENDIF
 IF(ASSOCIATED(IPF(IIPF)%XYPOS))THEN
  DEALLOCATE(IPF(IIPF)%XYPOS)
  NULLIFY(IPF(IIPF)%XYPOS)
 ENDIF
 IF(ASSOCIATED(IPF(IIPF)%IPOS))THEN
  DEALLOCATE(IPF(IIPF)%IPOS)
  NULLIFY(IPF(IIPF)%IPOS)
 ENDIF

 END SUBROUTINE IPFDEALLOCATEIIPF

 !###===============================================================================
 SUBROUTINE IPFPLOT(IIPF,XMIN,YMIN,XMAX,YMAX,IPLOT,XY,OFFSETX,LINITPROF)
 !###===============================================================================
 IMPLICIT NONE
 LOGICAL,INTENT(IN) :: LINITPROF
 INTEGER,INTENT(IN) :: IPLOT,IIPF
 REAL,INTENT(IN) :: XMIN,XMAX,YMIN,YMAX,OFFSETX
 REAL,INTENT(IN),DIMENSION(2,2) :: XY
 CHARACTER(LEN=256) :: DIR,FNAME
 INTEGER :: I,II,J,IRAT1,ICLR,PLOTSTYLE,IMARKDATA,NPOS,IPROF,IOS,IERROR,IEDGE,PIATTRIB,ILEG
 REAL :: X,Y,Z,Z2,DX,DY,TWIDTH,THEIGHT,XVAL,XDIS,YDIS,RAD,YROT,D
 REAL :: AXMIN,AYMIN,AXMAX,AYMAX
 REAL :: GXMIN,GYMIN,GXMAX,GYMAX
 REAL :: PXMIN,PYMIN,PXMAX,PYMAX
 REAL :: MNHV,MXHV,HV
 INTEGER,DIMENSION(:),ALLOCATABLE :: IATTRIB
 REAL,DIMENSION(:),ALLOCATABLE :: HVA,IDIPF
 REAL,DIMENSION(:,:),ALLOCATABLE :: COPY_GRAPHUNITS
 INTEGER(KIND=1) :: IP
 LOGICAL :: LPROF,LEX,LPROFPOTENTIAL

 LPROF=.FALSE.; IF(SUM(XY).NE.0.0)LPROF=.TRUE.
 IPROF=0; IF(LPROF)IPROF=1; YDIS=REAL(MP(IPLOT)%IDFI)
! ILEG=MAX(1,MP(IPLOT)%ILEGDLF)
 
 !## initial, determine number of files to be plotted
 IF(LINITPROF)THEN
  
  MP(IPLOT)%XMIN= 10.0E10; MP(IPLOT)%XMAX=-10.0E10
  MP(IPLOT)%YMIN= 10.0E10; MP(IPLOT)%YMAX=-10.0E10

  IF(LPROF)THEN   
   DX=XY(1,2)-XY(1,1); DY=XY(2,2)-XY(2,1); XDIS=SQRT(DX**2.0+DY**2.0); RAD=0.0; IF(DY.NE.0.0)RAD=ATAN2(DY,DX)
   DO I=1,IPF(IIPF)%NROW
    X=IPF(IIPF)%XYZ(1,I); Y=IPF(IIPF)%XYZ(2,I); Z=IPF(IIPF)%XYZ(3,I)
    IF(X.GE.XMIN.AND.X.LE.XMAX.AND.Y.GE.YMIN.AND.Y.LE.YMAX)THEN
     CALL IPFROTATEPOINT(X,Y,Z,XY,RAD,XDIS,YDIS,OFFSETX,IEDGE,YROT)
     IF(X.GE.0.0)THEN
      !## take the closest only - if defined before
      IF(IPF(IIPF)%IPOS(I).EQ.INT(1,1))THEN
       IF(ABS(YROT).LT.IPF(IIPF)%XYPOS(3,I))THEN
        IPF(IIPF)%XYPOS(1,I)=X; IPF(IIPF)%XYPOS(2,I)=Z; IPF(IIPF)%XYPOS(3,I)=ABS(YROT) 
       ENDIF
      ELSE
       IPF(IIPF)%XYPOS(1,I)=X; IPF(IIPF)%XYPOS(2,I)=Z; IPF(IIPF)%XYPOS(3,I)=ABS(YROT); IPF(IIPF)%IPOS(I)=INT(1,1)
      ENDIF
     ENDIF
    ENDIF
   ENDDO 
   RETURN

  ELSE

   !## normal 2d IPF plotting
   DO I=1,IPF(IIPF)%NROW
    X =IPF(IIPF)%XYZ(1,I); Y =IPF(IIPF)%XYZ(2,I)
    Z =IPF(IIPF)%XYZ(3,I); Z2=IPF(IIPF)%XYZ(4,I)
    MP(IPLOT)%XMIN=MIN(MP(IPLOT)%XMIN,X); MP(IPLOT)%XMAX=MAX(MP(IPLOT)%XMAX,X)
    MP(IPLOT)%YMIN=MIN(MP(IPLOT)%YMIN,Y); MP(IPLOT)%YMAX=MAX(MP(IPLOT)%YMAX,Y)
    IF(X.GE.XMIN.AND.X.LE.XMAX.AND.Y.GE.YMIN.AND.Y.LE.YMAX)THEN
     !## store current position (could be x/y or x/z in case profile are used!)
     IPF(IIPF)%XYPOS(1,I)=X; IPF(IIPF)%XYPOS(2,I)=Y; IPF(IIPF)%IPOS(I)=INT(1,1)
    ENDIF
   ENDDO
 
  ENDIF
 ENDIF
 
 !## read colouring info whenever ipfgetvalue/profiles is active
 CALL WINDOWSELECT(0)
 
! J=MAX(INDEX(IPF(IIPF)%FNAME,'\',.TRUE.)-1,1)

 IF(MP(IPLOT)%SYMBOL.LE.0.OR.MP(IPLOT)%SYMBOL.GT.40)MP(IPLOT)%SYMBOL=14
 IF(MP(IPLOT)%SCOLOR.LE.0)MP(IPLOT)%SCOLOR=WRGB(100,100,100)
 IF(MP(IPLOT)%IATTRIB.LE.0)MP(IPLOT)%IATTRIB=1
 IF(MP(IPLOT)%IATTRIB.GT.IPF(IIPF)%NCOL)MP(IPLOT)%IATTRIB=1

 !## find directory
 I=INDEXNOCASE(MP(IPLOT)%IDFNAME,'\',.TRUE.); DIR=MP(IPLOT)%IDFNAME(1:I-1)

 CALL WINDOWSELECT(0)
 IF(WMENUGETSTATE(ID_CONTLINES,2).EQ.1) PLOTSTYLE=1
 IF(WMENUGETSTATE(ID_BLOCKLINES,2).EQ.1)PLOTSTYLE=2
 IMARKDATA=WMENUGETSTATE(ID_MARKDATA,2)

 CALL WINDOWOUTSTATUSBAR(2,'') 
 CALL WINDOWOUTSTATUSBAR(4,'Drawing '//TRIM(IPF(IIPF)%ALIAS)) 

 CALL UTL_SETTEXTSIZE(TWIDTH,THEIGHT,REAL(MP(IPLOT)%TSIZE)*0.0025) 

 !## graphics setting of current graphical window
 GXMIN=WINFOGRREAL(GRAPHICSUNITMINX); GXMAX=WINFOGRREAL(GRAPHICSUNITMAXX)
 GYMIN=WINFOGRREAL(GRAPHICSUNITMINY); GYMAX=WINFOGRREAL(GRAPHICSUNITMAXY)
 AXMIN=WINFOGRREAL(GRAPHICSAREAMINX); AXMAX=WINFOGRREAL(GRAPHICSAREAMAXX)
 AYMIN=WINFOGRREAL(GRAPHICSAREAMINY); AYMAX=WINFOGRREAL(GRAPHICSAREAMAXY)

 !## graphical window
 IF(LPROF)THEN
  I=SIZE(GRAPHUNITS,1); J=SIZE(GRAPHUNITS,2)
  ALLOCATE(COPY_GRAPHUNITS(I,J)); COPY_GRAPHUNITS=GRAPHUNITS  
  PXMIN=GRAPHUNITS(1,1)
  PXMAX=GRAPHUNITS(3,1)
  PYMIN=GRAPHUNITS(2,1)
  PYMAX=GRAPHUNITS(4,1)
 ELSE
  PXMIN=GXMIN
  PXMAX=GXMAX
  PYMIN=GYMIN
  PYMAX=GYMAX
 ENDIF

 MP(IPLOT)%UMIN= 10.0E10; MP(IPLOT)%UMAX=-10.0E10

 IRAT1=0; NPOS =0

 !## get selected attributes for plotting
 IF(ABS(MP(IPLOT)%IEQ).GT.0)THEN
  ALLOCATE(IATTRIB(IPF(IIPF)%NCOL))
  CALL UTL_FILLARRAY(IATTRIB,IPF(IIPF)%NCOL,ABS(MP(IPLOT)%IEQ))
 ENDIF

 !## determine maximum highlight column value
 ALLOCATE(IDIPF(IPF(IIPF)%NROW)); DO I=1,IPF(IIPF)%NROW; IDIPF(I)=REAL(I); ENDDO
 IF(MP(IPLOT)%HCOL.GT.0)THEN
  MNHV=10.0E10; MXHV=-10.0E10; ALLOCATE(HVA(IPF(IIPF)%NROW))
  DO I=1,IPF(IIPF)%NROW
   READ(IPF(IIPF)%INFO(MP(IPLOT)%HCOL,I),*,IOSTAT=IOS) HV
   IF(IOS.EQ.0)THEN; MNHV=MIN(MNHV,HV); MXHV=MAX(MXHV,HV); HVA(I)=HV; ENDIF
  ENDDO
  HVA=-1.0*HVA
  !## from small (big negative weighs) to big (small negative weighs)
  CALL UTL_QKSORT2(HVA,IDIPF,IPF(IIPF)%NROW,IPF(IIPF)%NROW)
  DEALLOCATE(HVA)
 ENDIF
 
 IERROR = WINFOERROR(1) ! clear error flags first
 PIATTRIB=IPF(IIPF)%PCOL

 DO II=1,IPF(IIPF)%NROW
  I=INT(IDIPF(II))
  
!## do not use this otherwise the movie-button does not stop anymore
!  CALL WMESSAGEPEEK(ITYPE,MESSAGE)
!  IF(ITYPE.EQ.KEYDOWN.AND.MESSAGE%VALUE1.EQ.KEYESCAPE)EXIT
  
  Z =IPF(IIPF)%XYZ(3,I); Z2=IPF(IIPF)%XYZ(4,I)
  IF(IPF(IIPF)%IPOS(I).EQ.INT(1,1))THEN 
  
   IF(MP(IPLOT)%ILEG.EQ.0)THEN
    ICLR=MP(IPLOT)%SCOLOR
   ELSE
    IERROR = WINFOERROR(1)
    CALL ISTRINGTOREAL(IPF(IIPF)%INFO(MP(IPLOT)%IATTRIB,I),XVAL)
    ICLR=WRGB(200,200,200)
    IERROR = WINFOERROR(1)
    IF(IERROR.EQ.0)THEN 
     ICLR=UTL_IDFGETCLASS(MP(IPLOT)%LEG,XVAL)
     MP(IPLOT)%UMIN=MIN(MP(IPLOT)%UMIN,XVAL)
     MP(IPLOT)%UMAX=MAX(MP(IPLOT)%UMAX,XVAL)
    ENDIF
   ENDIF

   !## plot series
   IF(IPF(IIPF)%IP(I).EQ.INT(1,1).OR. &
      IPF(IIPF)%IP(I).EQ.INT(2,1).OR. &
      IPF(IIPF)%IP(I).EQ.INT(4,1))NPOS=NPOS+1 

   !## highlight certain column in ipf
   IF(MP(IPLOT)%HCOL.GT.0)CALL IPFHIGHLIGHT(IPF(IIPF)%XYPOS(1,I),IPF(IIPF)%XYPOS(2,I),IPF(IIPF)%INFO(MP(IPLOT)%HCOL,I), &
                    MP(IPLOT)%SYMBOL,MP(IPLOT)%THICKNESS,ICLR,MNHV,MXHV)

   CALL IGRCOLOURN(ICLR)
   IF(Z.NE.Z2.AND.LPROF)THEN
    CALL IPFPLOTLINE(IPF(IIPF)%XYPOS(1,I),IPF(IIPF)%XYPOS(2,I),Z2,3) 
   ELSE
    CALL IPFPLOTPOINT(IPF(IIPF)%XYPOS(1,I),IPF(IIPF)%XYPOS(2,I),MP(IPLOT)%SYMBOL,REAL(MP(IPLOT)%THICKNESS))
   ENDIF
    
   !## selected - cross on it
   IF(IPF(IIPF)%IP(I).EQ.INT(1,1).OR.&
      IPF(IIPF)%IP(I).EQ.INT(2,1).OR.&
      IPF(IIPF)%IP(I).EQ.INT(3,1).OR.&
      IPF(IIPF)%IP(I).EQ.INT(5,1))CALL IPFPLOTSELECTED(IIPF,I,IPROF,TWIDTH,THEIGHT,PIATTRIB)

   CALL IGRCOLOURN(ICLR)
   IF(ABS(MP(IPLOT)%IEQ).GT.0)CALL IPFPLOTLABEL(IPF(IIPF)%XYPOS(1,I),IPF(IIPF)%XYPOS(2,I),&
                 IPF(IIPF)%INFO(:,I),IATTRIB,IPF(IIPF)%NCOL,TWIDTH,THEIGHT,IPF(IIPF)%ATTRIB,LPROF,&
                 MP(IPLOT)%IEQ)

  ENDIF
 ENDDO

 MP(IPLOT)%DMIN=MP(IPLOT)%UMIN; MP(IPLOT)%DMAX=MP(IPLOT)%UMAX

 IF(I.LT.IPF(IIPF)%NROW)GOTO 10
 
 !## plot associated files
 CALL IPFINITASSFILE()
 !## allocate and nullify pointers
 CALL IPFASSFILEALLOCATE(MAX(1,NPOS))
 
 IF(ALLOCATED(GRAPHUNITS))DEALLOCATE(GRAPHUNITS); ALLOCATE(GRAPHUNITS(6,1)) 
 GRAPHUNITS(1,1)=0.0; GRAPHUNITS(2,1)=0.0; GRAPHUNITS(3,1)=1.0
 GRAPHUNITS(4,1)=1.0; GRAPHUNITS(5,1)=0.0; GRAPHUNITS(6,1)=1.0

 IRAT1=0; NPOS =0 
 !## plot selected associated files content
 DO II=1,IPF(IIPF)%NROW
  
  I=INT(IDIPF(II))
  IF(IPF(IIPF)%IPOS(I).NE.INT(1,1))CYCLE

!## do not use this otherwise the movie-button does not stop anymore
!  CALL WMESSAGEPEEK(ITYPE,MESSAGE); IF(ITYPE.EQ.KEYDOWN.AND.MESSAGE%VALUE1.EQ.KEYESCAPE)EXIT

  X=IPF(IIPF)%XYPOS(1,I); Y=IPF(IIPF)%XYPOS(2,I); D=IPF(IIPF)%XYPOS(3,I); D=(ABS(D)/YDIS)*REAL(MP(IPLOT)%FADEOUT)

  IF(IPF(IIPF)%IP(I).EQ.INT(1,1).OR.IPF(IIPF)%IP(I).EQ.INT(2,1).OR. &
     IPF(IIPF)%IP(I).EQ.INT(4,1))THEN

   !## plot series
   IF(IPF(IIPF)%IP(I).EQ.INT(1,1).OR.IPF(IIPF)%IP(I).EQ.INT(2,1))THEN
    NPOS=NPOS+1; IP=IPF(IIPF)%IP(I)
   ENDIF
   !## quickview
   IF(IPF(IIPF)%IP(I).EQ.INT(4,1))THEN
    NPOS=1; IP=INT(2,1)
   ENDIF

   IF(IPF(IIPF)%ACOL.NE.0)THEN

    FNAME=TRIM(DIR)//'\'//TRIM(IPF(IIPF)%INFO(IPF(IIPF)%ACOL,I))//'.'//TRIM(ADJUSTL(IPF(IIPF)%FEXT))
    !## read dimensions of associated file

    CALL IPFDIMENSIONASSFILE(NPOS,FNAME,IPF(IIPF)%IAXES)
    ASSF(NPOS)%ASSCOL1=IPF(IIPF)%ASSCOL1 !## column used with dlf
    ASSF(NPOS)%ASSCOL2=IPF(IIPF)%ASSCOL2 !## on default not used --- border rings
    ASSF(NPOS)%ILEGDLF=IPF(IIPF)%ILEGDLF !## used legend for colouring

    !## not equal to measurements --- activate current locations...
    IF(ASSF(NPOS)%ITOPIC.NE.1)IP=INT(1,1)
    !## in profiles use simple graph
    IF(LPROF)IP=1
    
    CALL IPFPLOTASSFILE(X,Y,D,NPOS,IP,PLOTSTYLE,PXMIN,PYMIN,PXMAX,PYMAX, &
                       IMARKDATA,LPROF,AXMIN,AXMAX,AYMIN,AYMAX,0,0,IPF(IIPF)%XYPOS(4,I),0,IIPF)
    !## copy z-coordinate to be able to select points in ipf_quickview
!    IF(ASSOCIATED(ASSF(NPOS)%Z))IPF(IIPF)%XYPOS(2,I)=ASSF(NPOS)%Z(1)   
    !## timeseries
    IF(ASSF(NPOS)%ITOPIC.EQ.1)THEN
     IPF(IIPF)%XYPOS(2,I)=Y !???
    !## boreholes
    ELSEIF(ASSF(NPOS)%ITOPIC.EQ.2)THEN
     IPF(IIPF)%XYPOS(2,I)=ASSF(NPOS)%Z(1)
!    IF(ASSOCIATED(ASSF(NPOS)%Z))IPF(IIPF)%XYPOS(2,I)=ASSF(NPOS)%Z(1)   
    !## sonderingen
    ELSEIF(ASSF(NPOS)%ITOPIC.EQ.3)THEN
     IPF(IIPF)%XYPOS(2,I)=ASSF(NPOS)%MEASURE(1,1)
    ENDIF
    
    CALL IPFPLOTSELECTED(IIPF,I,IPROF,TWIDTH,THEIGHT,PIATTRIB)
    
   ENDIF
  ENDIF
 ENDDO

10 CONTINUE

 CALL IGRAREA(AXMIN,AYMIN,AXMAX,AYMAX); CALL IGRUNITS(GXMIN,GYMIN,GXMAX,GYMAX)
 
  !## graphical window
 IF(LPROF)THEN
  I=SIZE(COPY_GRAPHUNITS,1); J=SIZE(COPY_GRAPHUNITS,2)
  IF(ALLOCATED(GRAPHUNITS))DEALLOCATE(GRAPHUNITS)
  ALLOCATE(GRAPHUNITS(I,J))  
  GRAPHUNITS=COPY_GRAPHUNITS
  IF(ALLOCATED(COPY_GRAPHUNITS))DEALLOCATE(COPY_GRAPHUNITS)
 ENDIF
 
 IF(ALLOCATED(IATTRIB))DEALLOCATE(IATTRIB); IF(ALLOCATED(IDIPF))  DEALLOCATE(IDIPF)
 CALL IPFCLOSEASSFILE()
 CALL IGRFILLPATTERN(OUTLINE); CALL IGRCOLOURN(WRGB(255,255,255))
 CALL WINDOWOUTSTATUSBAR(2,''); CALL WINDOWOUTSTATUSBAR(3,''); CALL WINDOWOUTSTATUSBAR(4,'')

 END SUBROUTINE IPFPLOT

 !###===============================================================================
 SUBROUTINE IPFPLOTSELECTED(IIPF,I,IPROF,TWIDTH,THEIGHT,PIATTRIB)
 !###===============================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IIPF,I,IPROF,PIATTRIB
 REAL,INTENT(IN) :: TWIDTH,THEIGHT
 REAL :: X,Y,DX,DY
 INTEGER :: J

 IF(IIPF.EQ.0.OR.I.EQ.0)RETURN
 
 CALL IGRCOLOURN(WRGB(255,0,0)) 
 IF(IPROF.EQ.0)THEN
  X =IPF(IIPF)%XYZ(1,I)
  Y =IPF(IIPF)%XYZ(2,I)
  DX=(MPW%XMAX-MPW%XMIN)/XSIZE
  DY=(MPW%YMAX-MPW%YMIN)/XSIZE
  DX=MIN(DX,DY)
  DY=DX
  !## mark
  CALL IGRJOIN(X-DX,Y,X+DX,Y)
  CALL IGRJOIN(X,Y-DY,X,Y+DY)
 ELSEIF(IPROF.EQ.1)THEN
  X =IPF(IIPF)%XYPOS(1,I)
  Y =IPF(IIPF)%XYPOS(2,I)
  DX=(GRAPHUNITS(3,1)-GRAPHUNITS(1,1))/(XSIZE/7.5)
  DY=(GRAPHUNITS(4,1)-GRAPHUNITS(2,1))/(XSIZE/7.5)
 ENDIF

 IF(PIATTRIB.NE.0)THEN
  CALL WGRTEXTFONT(FFHELVETICA,WIDTH=TWIDTH,HEIGHT=THEIGHT,ISTYLE=0)
  CALL WGRTEXTORIENTATION(ALIGNCENTRE,ANGLE=0.0)
  CALL IGRCOLOURN(WRGB(0,0,0)) 
  IF(IBACKSLASH.EQ.1)THEN
   J=INDEX(IPF(IIPF)%INFO(PIATTRIB,I),'\',.TRUE.)
   IF(J.GT.0)J=J+1
  ENDIF
  J=MAX(1,J)
  CALL WGRTEXTSTRING(X,Y+(1.5*DY),TRIM(IPF(IIPF)%INFO(PIATTRIB,I)(J:)))
 ENDIF
 
 END SUBROUTINE IPFPLOTSELECTED

 !###===============================================================================
 SUBROUTINE IPFPLOTPOINT(X,Y,SYMBOL,THICKNESS)
 !###===============================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: SYMBOL !,THICKNESS
 REAL,INTENT(IN) :: X,Y,THICKNESS

 CALL WGRTEXTFONT(WIDTH=(THICKNESS*0.4)/75.0,HEIGHT=(THICKNESS*0.2)/25.0)
 CALL IGRMARKER(X,Y,SYMBOL)

 END SUBROUTINE IPFPLOTPOINT

 !###===============================================================================
 SUBROUTINE IPFPLOTLINE(X,Z1,Z2,THICKNESS)
 !###===============================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: THICKNESS
 REAL,INTENT(IN) :: X,Z1,Z2

 CALL IGRLINEWIDTH(THICKNESS)
 CALL IGRJOIN(X,Z1,X,Z2)

 END SUBROUTINE IPFPLOTLINE

 !###===============================================================================
 SUBROUTINE IPFPLOTLABEL(X,Y,STRING,IATTRIB,NATTRIB,TWIDTH,THEIGHT,ATTRIB,LPROF,IEQ,GANGLE)
 !###===============================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NATTRIB,IEQ
 REAL,INTENT(IN) :: TWIDTH,THEIGHT
 CHARACTER(LEN=*),INTENT(IN),DIMENSION(NATTRIB) :: STRING,ATTRIB
 INTEGER,DIMENSION(NATTRIB),INTENT(IN) :: IATTRIB
 LOGICAL,INTENT(IN) :: LPROF
 REAL,INTENT(IN) :: X,Y
 REAL,INTENT(IN),OPTIONAL :: GANGLE
 REAL :: DX,DY,XC,YC,DXS,DYS
 INTEGER :: I,J
 CHARACTER(LEN=256) :: LINE

 !## nothing to draw
 IF(SUM(IATTRIB).EQ.0)RETURN

 CALL IGRLINEWIDTH(1)

 IF(LPROF)THEN

  CALL WGRTEXTFONT(TFONT,WIDTH=TWIDTH*1.5,HEIGHT=THEIGHT*1.5,ISTYLE=0)

  LINE=''
  DO I=SIZE(IATTRIB),1,-1
   IF(IATTRIB(I).EQ.1)THEN
    J=0
    IF(IBACKSLASH.EQ.1)THEN
     J=INDEX(STRING(I),'\',.TRUE.)
     IF(J.GT.0)J=J+1
    ENDIF
    J=MAX(1,J)
    IF(ILABELNAME.EQ.1)THEN 
     IF(LEN_TRIM(ATTRIB(I)).GT.0)THEN
      LINE=TRIM(LINE)//TRIM(ATTRIB(I))//'= '//TRIM(STRING(I)(J:))//';'
     ELSE
      LINE=TRIM(LINE)//TRIM(STRING(I)(J:))//';'    
     ENDIF
    ELSE
     LINE=TRIM(LINE)//TRIM(STRING(I)(J:))//';'    
    ENDIF
   ENDIF
  ENDDO
  I=INDEX(LINE,';',.TRUE.)
  IF(I.GT.0)LINE(I:I)=''

  !## place connection line
!  CALL WGRTEXTORIENTATION(ALIGNLEFT,ANGLE=90.0)
  IF(PRESENT(GANGLE))THEN
   CALL WGRTEXTORIENTATION(ALIGNLEFT,ANGLE=GANGLE)
  ELSE
   CALL WGRTEXTORIENTATION(ALIGNLEFT,ANGLE=90.0)
  ENDIF
  CALL WGRTEXTSTRING(X,Y,'   '//TRIM(LINE))

 ELSE

  CALL WGRTEXTFONT(TFONT,WIDTH=TWIDTH,HEIGHT=THEIGHT,ISTYLE=0)
  !## size of text character width/height in user units
  DXS=WINFOGRREAL(GRAPHICSCHWIDTH)
  DYS=WINFOGRREAL(GRAPHICSCHHEIGHT)
  IF(PRESENT(GANGLE))THEN
   CALL WGRTEXTORIENTATION(ALIGNLEFT,ANGLE=GANGLE)
  ELSE
   CALL WGRTEXTORIENTATION(ALIGNLEFT,ANGLE=0.0)
  ENDIF
  
  !## get size of box over labels
  DX=0.0
  DO I=1,SIZE(IATTRIB)
   IF(IATTRIB(I).EQ.1)THEN
    J=0
    IF(IBACKSLASH.EQ.1)THEN
     J=INDEX(STRING(I),'\',.TRUE.)
     IF(J.GT.0)J=J+1
    ENDIF
    J=MAX(1,J)
    IF(ILABELNAME.EQ.1)THEN
     IF(LEN_TRIM(ATTRIB(I)).GT.0)THEN
      DX=MAX(DX,WGRTEXTLENGTH('0'//TRIM(ATTRIB(I))//'= '//TRIM(STRING(I)(J:))//'0',0)*DXS)
     ELSE
      DX=MAX(DX,WGRTEXTLENGTH('0'//TRIM(STRING(I)(J:))//'0',0)*DXS)
     ENDIF
    ELSE
     DX=MAX(DX,WGRTEXTLENGTH('0'//TRIM(STRING(I)(J:))//'0',0)*DXS)
    ENDIF
   ENDIF
  END DO
  !## size of box for text
  DXS=DX

  DX=(WINFOGRREAL(GRAPHICSUNITMAXX)-WINFOGRREAL(GRAPHICSUNITMINX))/250.0
  DY= DYS*SUM(IATTRIB)
  XC= X+DX
  YC= Y-(DY/2.0)
  DX= WGRTEXTLENGTH('0',0)*WINFOGRREAL(GRAPHICSCHWIDTH)

  DO I=SIZE(IATTRIB),1,-1
   IF(IATTRIB(I).EQ.1)THEN
    IF(IEQ.GT.0)THEN
    ELSE
     CALL IGRFILLPATTERN(SOLID)
     CALL IGRCOLOURN(WRGB(0,0,0)) 
    ENDIF
    J=0
    IF(IBACKSLASH.EQ.1)THEN
     J=INDEX(STRING(I),'\',.TRUE.)
     IF(J.GT.0)J=J+1
    ENDIF
    J=MAX(1,J)
    IF(ILABELNAME.EQ.1)THEN
     IF(LEN_TRIM(ATTRIB(I)).GT.0)THEN
      CALL WGRTEXTSTRING(XC+DX,YC+(DYS/2.0),TRIM(ATTRIB(I))//'= '//STRING(I)(J:))
     ELSE
      CALL WGRTEXTSTRING(XC+DX,YC+(DYS/2.0),STRING(I)(J:))
     ENDIF
    ELSE
     CALL WGRTEXTSTRING(XC+DX,YC+(DYS/2.0),STRING(I)(J:))
    ENDIF
    YC=YC+DYS
   ENDIF
  END DO

  !## place connection line
  CALL IGRFILLPATTERN(OUTLINE)
  CALL IGRCOLOURN(WRGB(0,0,0)) !## black
  CALL IGRJOIN(X,Y,XC,Y)

 ENDIF

 END SUBROUTINE IPFPLOTLABEL

 !###===============================================================================
 SUBROUTINE IPFHIGHLIGHT(X,Y,STRING,SYMBOL,THICKNESS,ICLR,MNHV,MXHV)
 !###===============================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: SYMBOL,THICKNESS,ICLR
 CHARACTER(LEN=*),INTENT(IN) :: STRING
 REAL,INTENT(IN) :: X,Y,MNHV,MXHV
 REAL :: Z,LZ
 INTEGER :: IOS

 READ(STRING,*,IOSTAT=IOS) Z
 IF(IOS.NE.0)RETURN

 LZ=4.0*((Z-MNHV)/(MXHV-MNHV))
 LZ=LZ+1.0
 IF(Z.EQ.0.0)THEN
  CALL IGRCOLOURN(WRGB(0,0,0))
  CALL IPFPLOTPOINT(X,Y,SYMBOL,(LZ+1.0)*THICKNESS)
  CALL IGRCOLOURN(WRGB(255,255,255))
  CALL IPFPLOTPOINT(X,Y,SYMBOL,(LZ+0.5)*THICKNESS)
 ENDIF
 CALL IGRCOLOURN(ICLR)
 CALL IPFPLOTPOINT(X,Y,SYMBOL,LZ*THICKNESS)

 END SUBROUTINE IPFHIGHLIGHT

 !###===============================================================================
 SUBROUTINE IPFROTATEPOINT(X,Y,Z,XY,RAD,XDIS,YDIS,OFFSETX,IEDGE,YROT)
 !###===============================================================================
 IMPLICIT NONE
 REAL,INTENT(IN) :: Z,XDIS,YDIS,OFFSETX,RAD
 REAL,INTENT(IN),DIMENSION(2,2) :: XY
 REAL,INTENT(OUT) :: YROT
 INTEGER,INTENT(OUT) :: IEDGE
 REAL,INTENT(INOUT) :: X,Y
 REAL :: XROT,XNEW,YNEW,DIST

 !## perform coordinate shift first ... related to first point in segment!
 XNEW=X-XY(1,1)  !x1
 YNEW=Y-XY(2,1)  !y1
 DIST=0.0; IF(XNEW+YNEW.NE.0.0)DIST=SQRT(XNEW**2.0+YNEW**2.0)
 
 !## rotated coordinates becomes ...
 !  cos() sin()  !
 ! -sin() cos()  !
 XROT=XNEW* COS(RAD)+YNEW*SIN(RAD)       !## x1'
 YROT=XNEW*(-1.0*SIN(RAD))+YNEW*COS(RAD) !## y1'

 X=-999.9 
 Y=0.0 
 IEDGE=-999
 
 !## plot only if ....
 IF(XROT.GE.0.0.AND.  &     !x1>=0
    XROT.LE.XDIS.AND. &     !x1<=xdis
    ABS(YROT).LE.YDIS)THEN  !y1<=ydis and y2<=ydis
  X=XROT+OFFSETX 
  Y=Z
  IEDGE= 0
 !## point positions before line but within sightdepth
 ELSEIF(XROT.LT.0.0)THEN 
  DIST=0.0; IF(XROT+YROT.NE.0.0)DIST=SQRT(XROT**2.0+YROT**2.0)
  IF(DIST.LE.YDIS)THEN
   X=OFFSETX
   Y=Z 
   IEDGE=-1
   YROT=DIST
  ENDIF
 !## point positions after line but within sightdepth
 ELSEIF(XROT.GT.XDIS)THEN 
  DIST=0.0; IF((XROT-XDIS)+YROT.NE.0.0)DIST=SQRT((XROT-XDIS)**2.0+YROT**2.0)
  IF(DIST.LE.YDIS)THEN
   X=XDIS+OFFSETX
   Y=Z  
   IEDGE= 1
   YROT=DIST
  ENDIF
 ENDIF

 END SUBROUTINE IPFROTATEPOINT

 !###======================================================================
 LOGICAL FUNCTION IPFREAD(IPLOT,IIPF)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IPLOT,IIPF

 IPFREAD=.FALSE.

 !## adjust xcol,ycol,zcol to have minimal values
 IF(MP(IPLOT)%XCOL.LE.0) MP(IPLOT)%XCOL=1
 IF(MP(IPLOT)%YCOL.LE.0) MP(IPLOT)%YCOL=2
 IF(MP(IPLOT)%ZCOL.LE.0) MP(IPLOT)%ZCOL =MP(IPLOT)%XCOL
 IF(MP(IPLOT)%Z2COL.LE.0)MP(IPLOT)%Z2COL=MP(IPLOT)%XCOL
 
 IPF(IIPF)%FNAME=MP(IPLOT)%IDFNAME
 IPF(IIPF)%XCOL   =MP(IPLOT)%XCOL
 IPF(IIPF)%YCOL   =MP(IPLOT)%YCOL
 IPF(IIPF)%ZCOL   =MP(IPLOT)%ZCOL
 IPF(IIPF)%Z2COL  =MP(IPLOT)%Z2COL
 IPF(IIPF)%QCOL   =IPF(IIPF)%XCOL
 IPF(IIPF)%IAXES  =MP(IPLOT)%IAXES
 IPF(IIPF)%ASSCOL1=MP(IPLOT)%ASSCOL1
 IPF(IIPF)%ASSCOL2=MP(IPLOT)%ASSCOL2
 IPF(IIPF)%ILEGDLF=MP(IPLOT)%ILEGDLF
 IPF(IIPF)%ITYPE  =MAX(0,MIN(IPF(IIPF)%ITYPE,1))
 IPF(IIPF)%PCOL   =MP(IPLOT)%PCOL
 IF(.NOT.IPFREAD2(IIPF,1,1))RETURN

 IPFREAD=.TRUE.

 END FUNCTION IPFREAD

 !###======================================================================
 LOGICAL FUNCTION IPFWRITE(IIPF)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IIPF

 IPFWRITE=.FALSE.
 
 IPF(IIPF)%IU=UTL_GETUNITIPF(IPF(IIPF)%FNAME,'UNKNOWN')

 IF(.NOT.IPFWRITEHEADER(IIPF))RETURN
 IF(.NOT.IPFWRITEDATA(IIPF))RETURN

 IPFWRITE=.TRUE.
 
 END FUNCTION IPFWRITE

 !###======================================================================
 LOGICAL FUNCTION IPFREAD2(IIPF,IDATA,IQ)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IIPF,IDATA
 INTEGER :: I
 INTEGER,INTENT(IN) :: IQ 

 IPFREAD2=.FALSE.

 CALL IPFDEALLOCATEIIPF(IIPF)

 I=INDEX(IPF(IIPF)%FNAME,'\',.TRUE.)+1
 IPF(IIPF)%ALIAS=IPF(IIPF)%FNAME(I:)

 !## store ipf-file into memory
 IPF(IIPF)%IU=UTL_GETUNITIPF(IPF(IIPF)%FNAME,'OLD')
 IF(IPF(IIPF)%IU.EQ.0)RETURN

 IF(.NOT.IPFREADHEADER(IIPF,IQ))THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading header of'//CHAR(13)//'file '//TRIM(IPF(IIPF)%FNAME),'ERROR')
  RETURN
 ENDIF

 !## check existence of columns:
 IF(IPF(IIPF)%XCOL .GT.IPF(IIPF)%NCOL.OR.IPF(IIPF)%XCOL .LE.0.OR. &
    IPF(IIPF)%YCOL .GT.IPF(IIPF)%NCOL.OR.IPF(IIPF)%YCOL .LE.0.OR. &
    IPF(IIPF)%ZCOL .GT.IPF(IIPF)%NCOL.OR.IPF(IIPF)%ZCOL .LE.0.OR. &
    IPF(IIPF)%Z2COL.GT.IPF(IIPF)%NCOL.OR.IPF(IIPF)%Z2COL.LE.0.OR. &
    IPF(IIPF)%QCOL .GT.IPF(IIPF)%NCOL.OR.IPF(IIPF)%QCOL .LE.0)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK, &
    'XCOL ='//TRIM(ITOS(IPF(IIPF)%XCOL))//';'// &
    'YCOL ='//TRIM(ITOS(IPF(IIPF)%YCOL))//';'// &
    'ZCOL ='//TRIM(ITOS(IPF(IIPF)%ZCOL))//';'// &
    'Z2COL='//TRIM(ITOS(IPF(IIPF)%Z2COL))//';'// &
    'QCOL ='//TRIM(ITOS(IPF(IIPF)%QCOL))//CHAR(13)// &
    'Column definition >0 and <='//TRIM(ITOS(IPF(IIPF)%NCOL))//CHAR(13)// &
    'Select the IPF Configure dialog and change the configuration!','Error')
  RETURN
 ENDIF

 !## adjust if xcol,ycol,zcol exceed ipf(iipf)%ncol
 IPF(IIPF)%XCOL =MIN(IPF(IIPF)%NCOL,IPF(IIPF)%XCOL)
 IPF(IIPF)%YCOL =MIN(IPF(IIPF)%NCOL,IPF(IIPF)%YCOL)
 IPF(IIPF)%ZCOL =MIN(IPF(IIPF)%NCOL,IPF(IIPF)%ZCOL)
 IPF(IIPF)%Z2COL=MIN(IPF(IIPF)%NCOL,IPF(IIPF)%Z2COL)
 IPF(IIPF)%QCOL =MIN(IPF(IIPF)%NCOL,IPF(IIPF)%QCOL)
 
 IF(IDATA.EQ.1)THEN
  IF(.NOT.IPFREADDATA(IIPF,IQ))RETURN
 ENDIF
 
 IPFREAD2=.TRUE.

 END FUNCTION IPFREAD2

 !###======================================================================
 LOGICAL FUNCTION IPFREADHEADER(IIPF,IQ)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IIPF,IQ
 INTEGER :: IOS,I,CFN_N_ELEM
 CHARACTER(LEN=256) :: LINE
 
 IPFREADHEADER=.FALSE.

 READ(IPF(IIPF)%IU,'(A256)',IOSTAT=IOS) LINE 
 READ(LINE,*,IOSTAT=IOS) IPF(IIPF)%NROW
 
 !## ipf old style
 IF(IOS.EQ.0)THEN
  
  IPF(IIPF)%ITYPE=0 
  READ(IPF(IIPF)%IU,*,IOSTAT=IOS) IPF(IIPF)%NCOL
  IF(IOS.NE.0)RETURN
  IF(IPF(IIPF)%NCOL.LT.2)THEN !.OR.IPF(IIPF)%NROW.EQ.0)THEN
   IPFREADHEADER=.TRUE.
   IF(IQ.EQ.1)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'IPF does not contain any data and/or less than two columns!','Warning')
   RETURN
  ENDIF
 
  ALLOCATE(IPF(IIPF)%ATTRIB(IPF(IIPF)%NCOL))

  !## read ipf-file
  DO I=1,IPF(IIPF)%NCOL
   READ(IPF(IIPF)%IU,*,IOSTAT=IOS) IPF(IIPF)%ATTRIB(I)
   IF(IOS.NE.0)RETURN
  ENDDO
  IPF(IIPF)%ATTRIB=ADJUSTL(IPF(IIPF)%ATTRIB)

  READ(IPF(IIPF)%IU,*,IOSTAT=IOS) IPF(IIPF)%ACOL,IPF(IIPF)%FEXT
  IF(IOS.NE.0)RETURN
 
 !## ipf - csv style
 ELSE
 
  IPF(IIPF)%ITYPE=1
  IPF(IIPF)%NCOL=CFN_N_ELEM(' ,;',3,LINE)
  IF(IPF(IIPF)%NCOL.LT.2)THEN
   IPFREADHEADER=.TRUE.
   IF(IQ.EQ.1)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'IPF does not contain any data and/or less than two columns!','Warning')
   RETURN
  ENDIF

  ALLOCATE(IPF(IIPF)%ATTRIB(IPF(IIPF)%NCOL))
  READ(LINE,*) (IPF(IIPF)%ATTRIB(I),I=1,IPF(IIPF)%NCOL)
  IPF(IIPF)%NROW=0
  DO; READ(IPF(IIPF)%IU,*,IOSTAT=IOS); IF(IOS.NE.0)EXIT; IPF(IIPF)%NROW=IPF(IIPF)%NROW+1; ENDDO
  REWIND(IPF(IIPF)%IU); READ(IPF(IIPF)%IU,*)
  
  IPF(IIPF)%ACOL=0; IPF(IIPF)%FEXT='TXT'
  
 ENDIF
 
 IPFREADHEADER=.TRUE.

 END FUNCTION IPFREADHEADER

 !###======================================================================
 LOGICAL FUNCTION IPFWRITEHEADER(IIPF)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IIPF
 INTEGER :: IOS,I
 CHARACTER(LEN=256) :: LINE

 IPFWRITEHEADER=.FALSE.
 
 IF(IPF(IIPF)%ITYPE.EQ.0)THEN
 
  LINE=TRIM(ITOS(IPF(IIPF)%NROW))
  WRITE(IPF(IIPF)%IU,'(A)',IOSTAT=IOS) TRIM(LINE)
  IF(IOS.NE.0)RETURN
  LINE=TRIM(ITOS(IPF(IIPF)%NCOL))
  WRITE(IPF(IIPF)%IU,'(A)',IOSTAT=IOS) TRIM(LINE)
  IF(IOS.NE.0)RETURN

  DO I=1,IPF(IIPF)%NCOL
   WRITE(IPF(IIPF)%IU,'(A)',IOSTAT=IOS) TRIM(IPF(IIPF)%ATTRIB(I))
   IF(IOS.NE.0)RETURN
  ENDDO
  LINE=TRIM(ITOS(IPF(IIPF)%ACOL))//','//TRIM(IPF(IIPF)%FEXT)
  WRITE(IPF(IIPF)%IU,'(A)',IOSTAT=IOS) TRIM(LINE)
  IF(IOS.NE.0)RETURN
 
 ELSEIF(IPF(IIPF)%ITYPE.EQ.1)THEN
 
  LINE=TRIM(IPF(IIPF)%ATTRIB(1))
  DO I=2,IPF(IIPF)%NCOL
   WRITE(LINE,'(A)',IOSTAT=IOS) TRIM(LINE)//','//TRIM(IPF(IIPF)%ATTRIB(I))
   IF(IOS.NE.0)RETURN
  ENDDO
  WRITE(IPF(IIPF)%IU,'(A)',IOSTAT=IOS) TRIM(LINE)
 
 ENDIF
 
 IPFWRITEHEADER=.TRUE.

 END FUNCTION IPFWRITEHEADER

 !###======================================================================
 LOGICAL FUNCTION IPFREADDATA(IIPF,IQ)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IIPF,IQ
 INTEGER :: I,J,NU
 INTEGER,DIMENSION(0:6) :: IOS
 CHARACTER(LEN=1024) :: READLINE
 INTEGER,DIMENSION(5) :: IX,IY
 REAL,DIMENSION(5) :: X
 
 IPFREADDATA=.FALSE.

 IOS=0
 ALLOCATE(IPF(IIPF)%XYZ(5,IPF(IIPF)%NROW),STAT=IOS(1))
 ALLOCATE(IPF(IIPF)%XYPOS(4,IPF(IIPF)%NROW),STAT=IOS(2))
 ALLOCATE(IPF(IIPF)%INFO(IPF(IIPF)%NCOL,IPF(IIPF)%NROW),STAT=IOS(3))
 ALLOCATE(IPF(IIPF)%IP(IPF(IIPF)%NROW),STAT=IOS(4))
 ALLOCATE(IPF(IIPF)%IPOS(IPF(IIPF)%NROW),STAT=IOS(5))
 IF(SUM(IOS).NE.0)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot allocate enough memory to read the IPF','ERROR')
  RETURN
 ENDIF

 IPF(IIPF)%INFO=''
 
 IX(1)=IPF(IIPF)%XCOL
 IX(2)=IPF(IIPF)%YCOL
 IX(3)=IPF(IIPF)%ZCOL
 IX(4)=IPF(IIPF)%Z2COL
 IX(5)=IPF(IIPF)%QCOL
 IY=IX
 CALL UTL_GETUNIQUE_INT(IX,5,NU)
 DO I=1,5
  DO J=1,NU; IF(IY(I).EQ.IX(J))EXIT; ENDDO
  IY(I)=J
 ENDDO
 
ILOOP: DO I=1,IPF(IIPF)%NROW

  IOS=0
  READ(IPF(IIPF)%IU,'(A)',IOSTAT=IOS(0)) READLINE
  IF(IOS(0).NE.0)EXIT
  
  READ(READLINE,*,IOSTAT=IOS(1)) (IPF(IIPF)%INFO(J,I),J=1,IPF(IIPF)%NCOL)
  IF(IOS(1).NE.0)EXIT

  DO J=1,NU
   READ(IPF(IIPF)%INFO(IX(J),I),*,IOSTAT=IOS(J+1)) X(J)
   IF(IOS(J+1).NE.0)EXIT ILOOP
  ENDDO
  
  DO J=1,5; IPF(IIPF)%XYZ(J,I)=X(IY(J)); ENDDO
    
  IPF(IIPF)%IP(I)  =INT(0,1)

 ENDDO ILOOP

 IF(SUM(IOS).NE.0)THEN
  IF(IQ.EQ.1)THEN
   IF(IOS(0).NE.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Reading not enough records in '//CHAR(13)// &
      '['//TRIM(IPF(IIPF)%FNAME)//']','ERROR')
   IF(IOS(1).NE.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Number of specified columns does not match actual number of '// &
      'columns (check line ['//TRIM(ITOS(I+IPF(IIPF)%NCOL+3))//']'//CHAR(13)//'in ['//TRIM(IPF(IIPF)%FNAME)//']','ERROR')
   DO J=1,NU
    IF(IOS(2+J-1).NE.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Not able to transform column '//TRIM(ITOS(IX(J)))// &
             ' to a number in line ['//TRIM(ITOS(I+IPF(IIPF)%NCOL+3))//']'//CHAR(13)//'in ['//TRIM(IPF(IIPF)%FNAME)//']','ERROR')
   ENDDO
  ELSE
   !## no questions, continue without erroreneous lines
   IPFREADDATA=.TRUE.; IPF(IIPF)%NROW=I
  ENDIF
 ELSE
  IPFREADDATA=.TRUE.
 ENDIF

 CLOSE(IPF(IIPF)%IU); IPF(IIPF)%IU=0

 END FUNCTION IPFREADDATA

 !###======================================================================
 LOGICAL FUNCTION IPFWRITEDATA(IIPF)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IIPF
 INTEGER :: I,J
 INTEGER :: IOS
 CHARACTER(LEN=1024) :: LINE
 
 IPFWRITEDATA=.FALSE.

 DO I=1,IPF(IIPF)%NROW

  IF(INDEX(TRIM(IPF(IIPF)%INFO(1,I)),' ').GT.0)THEN
   LINE='"'//TRIM(IPF(IIPF)%INFO(1,I))//'"'
  ELSE
   LINE=TRIM(IPF(IIPF)%INFO(1,I))
  ENDIF
  DO J=2,IPF(IIPF)%NCOL
   IF(INDEX(TRIM(IPF(IIPF)%INFO(J,I)),' ').GT.0)THEN
    LINE=TRIM(LINE)//',"'//TRIM(IPF(IIPF)%INFO(J,I))//'"'
   ELSE
    LINE=TRIM(LINE)//','//TRIM(IPF(IIPF)%INFO(J,I))
   ENDIF
  END DO
  WRITE(IPF(IIPF)%IU,'(A)',IOSTAT=IOS) TRIM(LINE)
  IF(IOS.NE.0)RETURN

 ENDDO

 IPFWRITEDATA=.TRUE.

 CLOSE(IPF(IIPF)%IU)

 END FUNCTION IPFWRITEDATA

 !###======================================================================
 INTEGER FUNCTION UTL_GETUNITIPF(IPFNAME,TSTAT)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: IPFNAME
 CHARACTER(LEN=*),INTENT(IN) :: TSTAT
 LOGICAL :: LEX,LOPEN
 CHARACTER(LEN=10) :: TSTATUS

 TSTATUS=UTL_CAP(TSTAT,'U')
 UTL_GETUNITIPF=0

 INQUIRE(FILE=IPFNAME,OPENED=LOPEN)
 IF(LOPEN)THEN
  INQUIRE(FILE=IPFNAME,NUMBER=UTL_GETUNITIPF)
  CLOSE(UTL_GETUNITIPF)
 ENDIF

 IF(TRIM(TSTATUS).EQ.'OLD')THEN
  INQUIRE(FILE=IPFNAME,EXIST=LEX)
  IF(.NOT.LEX)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot find'//CHAR(13)//TRIM(IPFNAME),'Warning')
   RETURN
  ENDIF
  UTL_GETUNITIPF=UTL_GETUNIT()
  CALL OSD_OPEN(UTL_GETUNITIPF,FILE=IPFNAME,STATUS=TSTATUS,FORM='FORMATTED',ACTION='READ,DENYWRITE')
 ELSEIF(TRIM(TSTATUS).EQ.'UNKNOWN')THEN
  INQUIRE(FILE=IPFNAME,EXIST=LEX)
  IF(LEX)THEN
  ENDIF
  UTL_GETUNITIPF=UTL_GETUNIT()
  CALL OSD_OPEN(UTL_GETUNITIPF,FILE=IPFNAME,STATUS=TSTATUS,FORM='FORMATTED',ACTION='WRITE,DENYREAD') 
 ENDIF

 END FUNCTION UTL_GETUNITIPF

END MODULE MOD_IPF