!     Last change:  PTM  13 Sep 2011   10:17 pm
MODULE IMOD_UTL

INTEGER,PARAMETER :: NOS=3
!INTEGER, SAVE :: OS = 1                      !## operating system 1=dos,2=linux,3=unix
INTEGER :: OS
CHARACTER(LEN=20),DIMENSION(NOS),SAVE :: OSN

INTEGER,PARAMETER,PRIVATE :: MAXFILES=2000
INTEGER,PARAMETER :: ICF = 1 ! Intel compiler: ICF = 1
INTEGER,SAVE :: IUOUT
INTEGER,DIMENSION(2),SAVE :: IFLAG

CONTAINS

 !###====================================================
 LOGICAL FUNCTION UTL_EQUALS_REAL(A,B)
 !###====================================================
 IMPLICIT NONE
 REAL, INTENT(IN) :: A, B
 REAL :: EPS

 EPS=ABS(A)*EPSILON(A) ! SCALE EPSILON

 IF(EPS.EQ.0.0)THEN
  EPS=TINY (A) ! IF EPS UNDERFLOWED TO 0
 ! USE A VERY SMALL
 ! POSITIVE VALUE FOR EPSILON
 END IF

 IF(ABS(A-B).GT.EPS)THEN
  UTL_EQUALS_REAL=.FALSE. ! NOT EQUAL IF DIFFERENCE>EPS
 ELSE
  UTL_EQUALS_REAL=.TRUE.  ! EQUAL OTHERWISE
 ENDIF

 END FUNCTION UTL_EQUALS_REAL

 !###===================================================================
 SUBROUTINE IMOD_UTL_STRING(LINE)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(INOUT) :: LINE

 CALL IMOD_UTL_DELNULCHAR(LINE)
 CALL IMOD_UTL_DELCONTROLM(LINE)

 END SUBROUTINE IMOD_UTL_STRING

 !###===================================================================
 SUBROUTINE IMOD_UTL_FILENAME(LINE)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(INOUT) :: LINE
 LOGICAL :: LEX

 CALL IMOD_UTL_SWAPSLASH(LINE)
 LINE=ADJUSTL(LINE)
! !## check filename in case of unix/linux-mode
! IF(OS.EQ.2)CALL OSD_FILECASE(LINE,LEX)

 END SUBROUTINE IMOD_UTL_FILENAME

 !###===================================================================
 SUBROUTINE IMOD_UTL_DELNULCHAR(LINE)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(INOUT) :: LINE
 INTEGER :: I

 !## find ^M (null character)
 I=INDEX(LINE,CHAR(0))
 IF(I.EQ.0)RETURN
 !## replace by space
 LINE(I:I)=CHAR(32)

 END SUBROUTINE IMOD_UTL_DELNULCHAR

 !###===================================================================
 SUBROUTINE IMOD_UTL_DELCONTROLM(LINE)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(INOUT) :: LINE
 INTEGER :: I

 !#find ^M (carriage return)
 I=INDEX(LINE,CHAR(13))
 IF(I.LE.0)RETURN
 !#replace by space
 LINE(I:I)=CHAR(32)

 END SUBROUTINE IMOD_UTL_DELCONTROLM

 !###===================================================================
 SUBROUTINE IMOD_UTL_SWAPSLASH(LINE)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(INOUT) :: LINE
 INTEGER :: I,IFR,ITO

 CALL IMOD_UTL_OSSYSTEM()
 
 IF(OS.EQ.1)THEN
  IFR=47
  ITO=92
 ELSEIF(OS.EQ.2)THEN
  IFR=92
  ITO=47
 ENDIF

 DO
  I=INDEX(LINE,CHAR(IFR))
  IF(I.EQ.0)EXIT
  LINE(I:I)=CHAR(ITO)
 ENDDO

 END SUBROUTINE IMOD_UTL_SWAPSLASH

 !###===================================================================
 INTEGER FUNCTION IMOD_UTL_GETUNIT()
 !###===================================================================
 IMPLICIT NONE
 LOGICAL :: LEX
 
 DO IMOD_UTL_GETUNIT=20,MAXFILES
  INQUIRE(UNIT=IMOD_UTL_GETUNIT,OPENED=LEX)
  IF(.NOT.LEX)RETURN
 ENDDO

 CALL IMOD_UTL_PRINTTEXT('INCREASE IMOD_UTL_GETUNIT, MAX. FILES TO BE OPENED = '// &
      TRIM(IMOD_UTL_ITOS(MAXFILES))//'!',2)

 END FUNCTION IMOD_UTL_GETUNIT

 !###===================================================================
 SUBROUTINE IMOD_UTL_CHECKPATH(FNAME)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: FNAME
 INTEGER :: I

 I=0
 IF(OS.EQ.1)THEN
  I=INDEX(FNAME,':')
 ELSEIF(OS.EQ.2)THEN
  IF(FNAME(1:1).EQ.CHAR(92))I=1
  IF(FNAME(1:1).EQ.CHAR(47))I=1
 ENDIF
 IF(I.EQ.0)CALL IMOD_UTL_PRINTTEXT('You should specify entire path in the first line of the runfile!',2)

 END SUBROUTINE IMOD_UTL_CHECKPATH
 
 !###======================================================================
 SUBROUTINE IMOD_UTL_S_CAP(STR,TXT)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN)    :: TXT
 CHARACTER(LEN=*),INTENT(INOUT) :: STR
 INTEGER                        :: I,J,K,B1,B2

 IF(TXT.EQ.'l'.OR.TXT.EQ.'L')THEN
  B1= 65
  B2= 90
  K = 32
 ELSEIF(TXT.EQ.'u'.OR.TXT.EQ.'U')THEN
  B1= 97
  B2= 122
  K =-32
 ENDIF

 DO I=1,LEN_TRIM(STR)
  J=IACHAR(STR(I:I))
  IF(J.GE.B1.AND.J.LE.B2)J=J+K
  STR(I:I)=ACHAR(J)
 END DO

 END SUBROUTINE IMOD_UTL_S_CAP

!###======================================================================
 FUNCTION IMOD_UTL_CAP(STR,TXT)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: TXT,STR
 INTEGER :: I,J,K,B1,B2
 CHARACTER(LEN=256) :: IMOD_UTL_CAP

 IF(TXT.EQ.'l'.OR.TXT.EQ.'L')THEN
  B1= 65
  B2= 90
  K = 32
 ELSEIF(TXT.EQ.'u'.OR.TXT.EQ.'U')THEN
  B1= 97
  B2= 122
  K =-32
 ENDIF

 IMOD_UTL_CAP=''
 DO I=1,LEN_TRIM(STR)
  J=IACHAR(STR(I:I))
  IF(J.GE.B1.AND.J.LE.B2)J=J+K
  IMOD_UTL_CAP(I:I)=ACHAR(J)
 END DO

 END FUNCTION IMOD_UTL_CAP

 !###======================================================================
 FUNCTION ITOS(I)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: I
 CHARACTER(LEN=10)  :: TXT,ITOS

 WRITE(TXT,'(I10)') I
 !TXT=ADJUSTL(TXT)
 ITOS=ADJUSTL(TXT) !TXT

 END FUNCTION ITOS

 !###======================================================================
 CHARACTER(LEN=10) FUNCTION IMOD_UTL_ITOS(I)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN)             :: I
 CHARACTER(LEN=10)              :: TXT
 CHARACTER(LEN=1),DIMENSION(10) :: A
 INTEGER                        :: J,K

 WRITE(TXT,'(I10)') I
 READ(TXT,'(10A1)') A(1:10)
 DO J=1,10
  IF(A(J).NE.' ')EXIT
 END DO
 K=10-J+1
 WRITE(IMOD_UTL_ITOS(1:K),'(10A1)') A(J:10)
 IMOD_UTL_ITOS(K+1:)=''
END FUNCTION

 !###======================================================================
 FUNCTION IMOD_UTL_RTOS(X,F,NDEC)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NDEC
 REAL,INTENT(IN) :: X
 CHARACTER(LEN=1),INTENT(IN) :: F
 CHARACTER(LEN=15) :: TXT,FRM,IMOD_UTL_RTOS,CFN_SPRINTS_R
 INTEGER :: IOS

 IF(F.EQ.'*')THEN
  WRITE(TXT,*,IOSTAT=IOS) X
 ELSE
  WRITE(FRM,'(2A1,I2.2,A1,I2.2,A1)') '(',F,LEN(IMOD_UTL_RTOS),'.',NDEC,')'
  WRITE(TXT,FRM,IOSTAT=IOS) X
 ENDIF

 IF(IOS.NE.0)TXT='error'

 IMOD_UTL_RTOS=ADJUSTL(TXT)

 END FUNCTION IMOD_UTL_RTOS

 !###======================================================================
 FUNCTION RTOS(X,F,NDEC)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NDEC
 REAL,INTENT(IN) :: X
 CHARACTER(LEN=1),INTENT(IN) :: F
 CHARACTER(LEN=15) :: TXT,FRM,RTOS,CFN_SPRINTS_R
 INTEGER :: IOS

 IF(F.EQ.'*')THEN
  WRITE(TXT,*,IOSTAT=IOS) X
 ELSE
  WRITE(FRM,'(2A1,I2.2,A1,I2.2,A1)') '(',F,LEN(RTOS),'.',NDEC,')'
  WRITE(TXT,FRM,IOSTAT=IOS) X
 ENDIF

 IF(IOS.NE.0)TXT='error'

 RTOS=ADJUSTL(TXT)

 END FUNCTION RTOS

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

 DO I=10,MAXFILES 
  INQUIRE(UNIT=I,OPENED=LEX)
  IF(LEX)CLOSE(I)
 END DO

 END SUBROUTINE IMOD_UTL_CLOSEUNITS

 !###======================================================================
 LOGICAL FUNCTION IMOD_UTL_DIREXIST(DIRNAME)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIRNAME
 INTEGER :: IU, IOS
 CHARACTER(LEN=256) :: LINE
  
 IMOD_UTL_DIREXIST=.FALSE.
 !## try to create a file in folder
 IU=IMOD_UTL_GETUNIT()
 LINE=TRIM(DIRNAME)//'\tmp.tmp#0#1#2'
 CALL IMOD_UTL_SWAPSLASH(LINE)
 
 OPEN(IU,FILE=LINE,STATUS='UNKNOWN',IOSTAT=IOS)
 IF(IOS.EQ.0)THEN
  IMOD_UTL_DIREXIST=.TRUE.
  CLOSE(IU,STATUS='DELETE')
 ENDIF
 
 END FUNCTION IMOD_UTL_DIREXIST

 !###======================================================================
 REAL FUNCTION UTL_DIST(X1,Y1,X2,Y2)
 !###======================================================================
 IMPLICIT NONE
 REAL,INTENT(IN) :: X1,Y1,X2,Y2
 REAL :: DX,DY
 
 UTL_DIST=0.0
 
 DX=(X1-X2)**2.0
 DY=(Y1-Y2)**2.0
 IF(DX+DY.NE.0.0)UTL_DIST=SQRT(DX+DY)
 
 END FUNCTION UTL_DIST
 
 !###======================================================================
 SUBROUTINE IMOD_UTL_CREATEDIR(DIRNAME)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIRNAME
 CHARACTER(LEN=256) :: STRING

 STRING=DIRNAME
 CALL IMOD_UTL_SWAPSLASH(STRING)

 !#check entire path first ...
 IF(IMOD_UTL_DIREXIST(STRING))RETURN

 CALL IMOD_UTL_IOSDIRMAKE('"'//TRIM(STRING)//'"')

 IF(.NOT.IMOD_UTL_DIREXIST(STRING))CALL IMOD_UTL_PRINTTEXT('Could not create directory: '//TRIM(STRING),2)
 
 END SUBROUTINE IMOD_UTL_CREATEDIR

 !###====================================================================
 SUBROUTINE IMOD_UTL_IOSDIRMAKE(DIR)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 CHARACTER(LEN=256) :: STRING

 STRING=DIR
 CALL IMOD_UTL_SWAPSLASH(STRING)
 IF(OS.EQ.1)STRING='mkdir '//TRIM(STRING)
 IF(OS.EQ.2)STRING='mkdir -p '//TRIM(STRING)
 CALL SYSTEM(STRING)

 END SUBROUTINE IMOD_UTL_IOSDIRMAKE

 !###====================================================================
 SUBROUTINE IMOD_UTL_IOSDELDIR(DIR)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 CHARACTER(LEN=256) :: STRING

 STRING=DIR
 CALL IMOD_UTL_SWAPSLASH(STRING)
 IF(OS.EQ.1)STRING='del /q '//TRIM(STRING)
 IF(OS.EQ.2)STRING='/bin/rm -rf '//TRIM(STRING)
 CALL SYSTEM(STRING)

 END SUBROUTINE IMOD_UTL_IOSDELDIR

 !###====================================================================
 INTEGER FUNCTION IMOD_UTL_IDATETOJDATE(IDATE,FNAME)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IDATE
 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: FNAME
 INTEGER :: IY,IM,ID 

 IMOD_UTL_IDATETOJDATE=0

 IY = IDATE / 10000
 IM = MOD( IDATE, 10000 ) / 100
 ID = MOD( IDATE, 100 ) 

 IF(IM.LE.0.OR.IM.GT.12)THEN
  CALL IMOD_UTL_PRINTTEXT('',0)
  CALL IMOD_UTL_PRINTTEXT('Error converting current date ['//TRIM(IMOD_UTL_ITOS(IDATE))//'] into julian data',0)
  IF(PRESENT(FNAME))CALL IMOD_UTL_PRINTTEXT('Occured in file: '//TRIM(FNAME),0)
  CALL IMOD_UTL_PRINTTEXT('',2)
 ENDIF
 IF(ID.LE.0.OR.ID.GT.IMOD_UTL_DATEDAYSINMONTH(IY,IM))THEN
  CALL IMOD_UTL_PRINTTEXT('',0)
  CALL IMOD_UTL_PRINTTEXT('Error converting current date ['//TRIM(IMOD_UTL_ITOS(IDATE))//'] into julian data',0)
  IF(PRESENT(FNAME))CALL IMOD_UTL_PRINTTEXT('Occured in file: '//TRIM(FNAME),0)
  CALL IMOD_UTL_PRINTTEXT('',2)
 ENDIF

 IMOD_UTL_IDATETOJDATE=IMOD_UTL_JD(IY,IM,ID)

 END FUNCTION

 !###====================================================================
 INTEGER FUNCTION IMOD_UTL_JDATETOIDATE(JDATE)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: JDATE
 INTEGER            :: IY,IM,ID

 CALL IMOD_UTL_GDATE(JDATE,IY,IM,ID)
 IMOD_UTL_JDATETOIDATE=IY*10000+IM*100+ID

 END FUNCTION IMOD_UTL_JDATETOIDATE

 !###======================================================================
 FUNCTION IMOD_UTL_JDATETOGDATE(I)
 !###======================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: I
 CHARACTER(LEN=10)  :: IMOD_UTL_JDATETOGDATE
 INTEGER :: IY,IM,ID

 CALL IMOD_UTL_GDATE(I,IY,IM,ID)
 IMOD_UTL_JDATETOGDATE=TRIM(IMOD_UTL_ITOS(ID))//'/'//TRIM(IMOD_UTL_ITOS(IM))//'/'//TRIM(IMOD_UTL_ITOS(IY))

 END FUNCTION IMOD_UTL_JDATETOGDATE

 !###======================================================================
 INTEGER FUNCTION IMOD_UTL_GDATETOJDATE(CDATE)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: CDATE
 INTEGER :: IY,IM,ID,I,J,MD
 INTEGER,DIMENSION(3) :: IOS

 IOS=1

 I=INDEX(CDATE,'/',.FALSE.)
 IF(I.GT.0)THEN
  READ(CDATE(1:I-1),*,IOSTAT=IOS(1)) ID
  J=INDEX(CDATE,'/',.TRUE.)
  IF(J.GT.0)THEN
   READ(CDATE(J+1:),*,IOSTAT=IOS(3)) IY
   IF(J-I.GT.0)READ(CDATE(I+1:J-1),*,IOSTAT=IOS(2)) IM
  ENDIF
 ENDIF

 !## initialize default value
 IMOD_UTL_GDATETOJDATE=0

 IM=MAX(1,MIN(12,IM))
 MD=IMOD_UTL_DATEDAYSINMONTH(IY,IM)
 ID=MAX(1,MIN(MD,ID))

 !## error reading dates
 IF(SUM(IOS).NE.0)RETURN

 IMOD_UTL_GDATETOJDATE=IMOD_UTL_JD(IY,IM,ID)

 END FUNCTION IMOD_UTL_GDATETOJDATE

 !###===================================================================
 INTEGER FUNCTION IMOD_UTL_DATEDAYSINMONTH(IY,IM)
 !###===================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IY,IM

 SELECT CASE (IM)
  CASE (2)
   IMOD_UTL_DATEDAYSINMONTH=28
   IF((MOD(IY,100).NE.0.AND.MOD(IY,4).EQ.0) .OR. MOD(IY,400).EQ.0)IMOD_UTL_DATEDAYSINMONTH=29
  CASE (1,3,5,7,8,10,12)
   IMOD_UTL_DATEDAYSINMONTH=31
  CASE DEFAULT
   IMOD_UTL_DATEDAYSINMONTH=30
 END SELECT

 END FUNCTION IMOD_UTL_DATEDAYSINMONTH

 !###===================================================================
 INTEGER FUNCTION IMOD_UTL_JD(YEAR,MONTH,DAY)
 !###===================================================================
 !EXTRACTED FROM THE INTERNET: http://aa.usno.navy.mil/faq/docs/JD_Formula.html
 !COMPUTES THE JULIAN DATE (JD) GIVEN A GREGORIAN CALENDAR DATE (YEAR,MONTH,DAY).
 !EXAMPLE: YEAR=1970,MONTH=1,DAY=1,JD=2440588
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: YEAR,MONTH,DAY
 INTEGER            :: I,J,K

 I =YEAR
 J =MONTH
 K =DAY
 IMOD_UTL_JD=K-32075+1461*(I+4800+(J-14)/12)/4+367*(J-2-(J-14)/12*12) &
             /12-3*((I+4900+(J-14)/12)/100)/4

 END FUNCTION IMOD_UTL_JD

 !###===================================================================
 SUBROUTINE IMOD_UTL_GDATE(JD,YEAR,MONTH,DAY)
 !###===================================================================
 !EXTRACTED FROM THE INTERNET: http://aa.usno.navy.mil/faq/docs/JD_Formula.html
 !COMPUTES THE GREGORIAN CALENDAR DATE (YEAR,MONTH,DAY) GIVEN THE JULIAN DATE (JD).
 IMPLICIT NONE
 INTEGER,INTENT(IN)  :: JD
 INTEGER,INTENT(OUT) :: YEAR,MONTH,DAY
 INTEGER             :: I,J,K,L,N

 L=JD+68569
 N=4*L/146097
 L=L-(146097*N+3)/4
 I=4000*(L+1)/1461001
 L=L-1461*I/4+31
 J=80*L/2447
 K=L-2447*J/80
 L=J/11
 J=J+2-12*L
 I=100*(N-49)+I+L

 YEAR =I
 MONTH=J
 DAY  =K

 END SUBROUTINE IMOD_UTL_GDATE

 !###===================================================================
 SUBROUTINE IMOD_UTL_MODEL1CHECKFNAME(FNAME,LU)
 !###===================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: LU
 CHARACTER(LEN=*),INTENT(IN) :: FNAME
 REAL :: X
 INTEGER :: IOS,I,J
 LOGICAL :: LEX

 IF(LEN_TRIM(FNAME).EQ.0)THEN
  IF(LU.EQ.0)CALL IMOD_UTL_PRINTTEXT('No file given',2)
  IF(LU.GT.0)THEN
   WRITE(LU,*) 'Error:'
   WRITE(LU,*) '  No file given'
  ENDIF
 ENDIF

 !get first non character
 I=0
 DO
  I=I+1
  J=ICHAR(FNAME(I:I))
  IF(J.GT.32)EXIT
 ENDDO

 X=IMOD_UTL_GETREAL(FNAME(I:),IOS)
 IF(IOS.NE.0)THEN

  INQUIRE(FILE=FNAME(I:),OPENED=LEX)
  IF(LEX)RETURN

  INQUIRE(FILE=FNAME(I:),EXIST=LEX)
  IF(.NOT.LEX)THEN
   IF(LU.EQ.0)CALL IMOD_UTL_PRINTTEXT('File '//TRIM(FNAME(I:))//' does not exist !',2)
   IF(LU.GT.0)THEN
    WRITE(LU,*) 'Error:'
    WRITE(LU,*)    TRIM(FNAME(I:))//' does not exist!'
   ENDIF
  ENDIF

 ENDIF

 END SUBROUTINE

 !###===================================================================
 CHARACTER(LEN=256) FUNCTION IMOD_UTL_GETFNAME(LINE)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: LINE
 INTEGER :: I,J,K

 K=39
 I=INDEX(LINE,CHAR(K),.FALSE.)  !## '-tje
 IF(I.EQ.0)THEN
  K=34
  I=INDEX(LINE,CHAR(K),.FALSE.) !## "-tje
 ENDIF
 !## quotes found, find other, to be sure it is consistent
 IF(I.GT.0)THEN
  J=INDEX(LINE,CHAR(K),.TRUE.)
  IF(I.EQ.J)THEN
   CALL IMOD_UTL_PRINTTEXT('',0)
   CALL IMOD_UTL_PRINTTEXT('Missing second quote '//CHAR(K)//' in line:',0)
   CALL IMOD_UTL_PRINTTEXT(TRIM(LINE),0)
   CALL IMOD_UTL_PRINTTEXT('',2)
  ENDIF
  IMOD_UTL_GETFNAME=LINE(I+1:J-1)
 ELSE
  !## search for comma's, backward
  I=INDEX(TRIM(LINE),',',.TRUE.)
  J=INDEX(TRIM(LINE),' ',.TRUE.)
  IMOD_UTL_GETFNAME=LINE(MAX(I+1,J+1):) !J-1)
 ENDIF

 END FUNCTION IMOD_UTL_GETFNAME

 !###===================================================================
 REAL FUNCTION IMOD_UTL_GETREAL(LINE,IOS)
 !###===================================================================
 IMPLICIT NONE
 INTEGER,INTENT(OUT) :: IOS
 CHARACTER(LEN=*),INTENT(IN) :: LINE
 INTEGER :: ITYPE,CFN_DETERM_TYPE

 READ(LINE,*,IOSTAT=IOS) IMOD_UTL_GETREAL
 IF(IOS.NE.0)IMOD_UTL_GETREAL=0.0
 
 END FUNCTION IMOD_UTL_GETREAL

 !###===================================================================
 INTEGER FUNCTION IMOD_UTL_GETIDFTYPE(FNAME)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: FNAME
 INTEGER :: I,RDRS_TYPE,IU

 IMOD_UTL_GETIDFTYPE=0

 !CALL OPENIDF(IU,FNAME,'R',4)
 READ(IU,REC=1) I
 IF(I.EQ.1271)IMOD_UTL_GETIDFTYPE=1
 CLOSE(IU)

 END FUNCTION IMOD_UTL_GETIDFTYPE

 !###====================================================
 SUBROUTINE IMOD_UTL_GETMED(X,NX,NODATA,PERC,NPERC,MX,XMED)
 !###====================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NX,NPERC            !## size array,number of percentiles to be comp.
 INTEGER,INTENT(OUT) :: MX                 !## number of values ne nodata
 REAL,INTENT(IN),DIMENSION(NPERC) :: PERC  !## percentile 0-100%
 REAL,INTENT(OUT),DIMENSION(NPERC) :: XMED !## yielding percentile(s)
 REAL,INTENT(IN) :: NODATA                 !## nodata value !,PERC
 REAL,DIMENSION(NX),INTENT(INOUT) :: X     !## array
 INTEGER :: I,J,IP
 REAL :: FRAC

 XMED=NODATA 

 IF(NX.LE.0)RETURN

 !## only one sample
 IF(NX.EQ.1)THEN
  XMED=X(1)
  MX  =1
  RETURN
 ENDIF

 !## do not include nodata values for median-computation
 MX=0
 DO I=1,NX
  IF(X(I).NE.NODATA)THEN
   MX   =MX+1
   X(MX)=X(I)
  ENDIF
 END DO

 IF(MX.LE.0)RETURN

 !## sort data, excl. nodata values
 IF(MX.LE.100)THEN
  CALL IMOD_UTL_SHELLSORT(MX,X)
 ELSE
  CALL IMOD_UTL_QKSORT(MX,MX,X)
 ENDIF

 DO IP=1,NPERC

  IF(PERC(IP).LE.0.0)THEN
   XMED(IP)=X(1)
  ELSEIF(PERC(IP).GE.100.0)THEN
   XMED(IP)=X(MX) 
  ELSE
   FRAC=1.0/(PERC(IP)/100.0)

   IF(MOD(REAL(MX),FRAC).EQ.0.0)THEN
    I=INT(REAL(MX)/FRAC)
    XMED(IP)=X(I)
   ELSE
    I=MAX(1,INT(REAL(MX)/FRAC))
    J=MIN(I+1,MX)
    XMED(IP)=(X(I)+X(J))/2.0
   ENDIF
  ENDIF
 ENDDO

 END SUBROUTINE IMOD_UTL_GETMED

!====================================================
SUBROUTINE IMOD_UTL_QKSORT(NDIM,N,ARR)
!====================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: N,NDIM
REAL,INTENT(INOUT),DIMENSION(NDIM) :: ARR
INTEGER :: M,NSTACK
PARAMETER (M=7,NSTACK=50)
INTEGER :: I,IR,J,JSTACK,K,L,ISTACK(NSTACK)
REAL :: A,TEMP

JSTACK=0
L=1
IR=N
1 IF(IR-L.LT.M)THEN
 DO J=L+1,IR
  A=ARR(J)
  DO I=J-1,1,-1
   IF(ARR(I).LE.A)GOTO 2
   ARR(I+1)=ARR(I)
  ENDDO
  I=0
2   ARR(I+1)=A
 ENDDO
 IF(JSTACK.EQ.0)RETURN
 IR=ISTACK(JSTACK)
 L=ISTACK(JSTACK-1)
 JSTACK=JSTACK-2
ELSE
 K=(L+IR)/2
 TEMP=ARR(K)
 ARR(K)=ARR(L+1)
 ARR(L+1)=TEMP
 IF(ARR(L+1).GT.ARR(IR))THEN
  TEMP=ARR(L+1)
  ARR(L+1)=ARR(IR)
  ARR(IR)=TEMP
 ENDIF
 IF(ARR(L).GT.ARR(IR))THEN
  TEMP=ARR(L)
  ARR(L)=ARR(IR)
  ARR(IR)=TEMP
 ENDIF
 IF(ARR(L+1).GT.ARR(L))THEN
  TEMP=ARR(L+1)
  ARR(L+1)=ARR(L)
  ARR(L)=TEMP
 ENDIF
 I=L+1
 J=IR
 A=ARR(L)
3  CONTINUE
 I=I+1
 IF(ARR(I).LT.A)GOTO 3
4  CONTINUE
 J=J-1
 IF(ARR(J).GT.A)GOTO 4
 IF(J.LT.I)GOTO 5
 TEMP=ARR(I)
 ARR(I)=ARR(J)
 ARR(J)=TEMP
 GOTO 3
5  ARR(L)=ARR(J)
 ARR(J)=A
 JSTACK=JSTACK+2
 IF(JSTACK.GT.NSTACK)PAUSE 'NSTACK TOO SMALL'
 IF(IR-I+1.GT.J-L)THEN
  ISTACK(JSTACK)=IR
  ISTACK(JSTACK-1)=I
  IR=J-1
 ELSE
  ISTACK(JSTACK)=J-1
  ISTACK(JSTACK-1)=L
  L=I
 ENDIF
ENDIF
GOTO 1

END SUBROUTINE IMOD_UTL_QKSORT

 !###====================================================
 SUBROUTINE IMOD_UTL_SHELLSORT(N,A)
 !###====================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: N
 REAL,DIMENSION(N),INTENT(INOUT) :: A
 INTEGER            :: I,J,INC
 REAL               :: V

 INC=1
 1 INC=3*INC+1
 IF(INC.LE.N)GOTO 1
 2 CONTINUE
  INC=INC/3
  DO I=INC+1,N
   V=A(I)
   J=I
 3 IF(A(J-INC).GT.V)THEN
    A(J)=A(J-INC)
    J=J-INC
    IF(J.LE.INC)GOTO 4
    GOTO 3
   ENDIF
 4  A(J)=V
  END DO
 IF(INC.GT.1)GOTO 2

 END SUBROUTINE

 !###==================================================================
 SUBROUTINE IMOD_UTL_POL1INTMAIN(NCOL,NROW,NPC,NPR,XCRD,YCRD,ZCRD,DELR,DELC,X, &
                        IINT,NODATA)
 !###==================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NCOL,NROW,NPC,NPR,IINT
 REAL,INTENT(IN) :: NODATA
 REAL,DIMENSION(NPC),INTENT(IN) :: XCRD       !fixed point x-coordinates
 REAL,DIMENSION(NPR),INTENT(IN) :: YCRD       !fixed point y-coordinates
 REAL,DIMENSION(NPC,NPR),INTENT(IN) :: ZCRD   !fixed point values
 REAL,DIMENSION(0:NCOL),INTENT(IN) :: DELR
 REAL,DIMENSION(0:NROW),INTENT(IN) :: DELC
 REAL,DIMENSION(NCOL,NROW),INTENT(INOUT) :: X
 REAL :: Y,DY,X1,X2
 INTEGER :: NMAX,IROW,ICOL !,ITYPE
 !TYPE(WIN_MESSAGE) :: MESSAGE
 REAL,ALLOCATABLE,DIMENSION(:) :: C,D,YMTMP,YNTMP

 NMAX=MAX(NPR,NPC)
 IF(ALLOCATED(C))DEALLOCATE(C)
 IF(ALLOCATED(D))DEALLOCATE(D)
 IF(ALLOCATED(YMTMP))DEALLOCATE(YMTMP)
 IF(ALLOCATED(YNTMP))DEALLOCATE(YNTMP)
 ALLOCATE(C(NMAX),D(NMAX),YNTMP(NPR),YMTMP(NPC))

 !X1=202560.0
 !X2=400050.0
 !CALL POL2DINT(XCRD,YCRD,ZCRD,C,D,NMAX,YMTMP,YNTMP,NPC,NPR,X1,X2,Y,DY)
 !WRITE(*,*) Y,DY
 !PAUSE

 !loop over all points!
 DO IROW=1,NROW
  DO ICOL=1,NCOL
   X1=(DELR(ICOL-1)+DELR(ICOL))/2.0
   X2=(DELC(IROW-1)+DELC(IROW))/2.0
   CALL IMOD_UTL_POL2DINT(XCRD,YCRD,ZCRD,C,D,NMAX,YMTMP,YNTMP,NPC,NPR,X1,X2,Y,DY,IINT,NODATA)
   X(ICOL,IROW)=Y
  ENDDO
 ENDDO

 END SUBROUTINE IMOD_UTL_POL1INTMAIN

 !###==================================================================
 SUBROUTINE IMOD_UTL_POL2DINT(XCRD,YCRD,ZCRD,C,D,NMAX,YMTMP,YNTMP,NPC,NPR,XINT,&
                     YINT,Y,DY,IINT,NODATA)
 !###==================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NPC,NPR,NMAX,IINT
 REAL,INTENT(IN) :: NODATA
 REAL,DIMENSION(NPC),INTENT(IN) :: XCRD
 REAL,DIMENSION(NPR),INTENT(IN) :: YCRD
 REAL,DIMENSION(NPC,NPR) :: ZCRD
 REAL,INTENT(IN) :: XINT,YINT
 REAL,INTENT(OUT) :: DY,Y
 REAL,DIMENSION(NPR),INTENT(INOUT) :: YNTMP
 REAL,DIMENSION(NPC),INTENT(INOUT) :: YMTMP
 REAL,DIMENSION(NMAX),INTENT(INOUT) :: C,D
 INTEGER :: J,K,XPOS,XPOS1,XPOS2,DXPOS,YPOS,YPOS1,YPOS2,DYPOS,DPOS,INODATA

 CALL IMOD_UTL_POL1LOCATE(XCRD,NPC,XINT,XPOS)
 CALL IMOD_UTL_POL1LOCATE(YCRD,NPR,YINT,YPOS)

 DPOS =INT(SQRT(REAL(IINT)))   !iint=4,dpos=2; iint=16,dpos=4
 DPOS =DPOS/2

 XPOS1=MAX(1,XPOS-(DPOS-1))
 XPOS2=MIN(XPOS+DPOS,NPC)
 DXPOS=(XPOS2-XPOS1)+1

 YPOS1=MAX(1,YPOS-(DPOS-1))
 YPOS2=MIN(YPOS+DPOS,NPR)
 DYPOS=(YPOS2-YPOS1)+1

 INODATA=0
 JLOOP: DO J=XPOS1,XPOS2
  DO K=YPOS1,YPOS2
   YNTMP(K)=ZCRD(J,K)
   IF(ZCRD(J,K).EQ.NODATA)THEN
    INODATA=1
    EXIT JLOOP
   ENDIF
  END DO
  CALL IMOD_UTL_POL1DINT(YCRD(YPOS1),YNTMP(YPOS1),C,D,DYPOS,NMAX,YINT,YMTMP(J),DY)
 END DO JLOOP

 IF(INODATA.EQ.1)THEN
  Y =NODATA
  DY=0.0
 ELSE
  CALL IMOD_UTL_POL1DINT(XCRD(XPOS1),YMTMP(XPOS1),C,D,DXPOS,NMAX,XINT,Y,DY)
 ENDIF

 !all/everything
 !DO J=1,NPC
 ! DO K=1,NPR
 !  YNTMP(K)=ZCRD(J,K)
 ! END DO
 ! CALL POL1DINT(YCRD,YNTMP,C,D,NPR,NMAX,YINT,YMTMP(J),DY)
 !END DO
 !CALL POL1DINT(XCRD,YMTMP,C,D,NPC,NMAX,XINT,Y,DY)

 END SUBROUTINE IMOD_UTL_POL2DINT

 !###==================================================================
 SUBROUTINE IMOD_UTL_POL1DINT(XA,YA,C,D,NPR,NMAX,X,Y,DY)
 !###==================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NPR,NMAX
 REAL,DIMENSION(NPR),INTENT(IN) :: XA,YA
 REAL,DIMENSION(NMAX),INTENT(INOUT) :: C,D
 REAL,INTENT(IN) :: X
 REAL,INTENT(OUT) :: DY,Y
 INTEGER :: I,M,NS
 REAL :: DEN,DIF,DIFT,HO,HP,W

 NS =1
 DIF=ABS(X-XA(1))

 DO I=1,NPR
  DIFT=ABS(X-XA(I))
  IF(DIFT.LT.DIF)THEN
   NS =I
   DIF=DIFT
  ENDIF
  C(I)=YA(I)
  D(I)=YA(I)
 END DO

 Y =YA(NS)
 NS=NS-1

 DO M=1,NPR-1
  DO I=1,NPR-M
   HO =XA(I)-X
   HP =XA(I+M)-X
   W  =C(I+1)-D(I)
   DEN=HO-HP
   IF(DEN.EQ.0.0)PAUSE 'FAILURE IN POLINT' !occurs whenever two xa(i) are almost the same
   DEN=W/DEN
   D(I)=HP*DEN
   C(I)=HO*DEN
  END DO
  IF(2*NS.LT.NPR-M)THEN
   DY=C(NS+1)
  ELSE
   DY=D(NS)
   NS=NS-1
  ENDIF
  Y=Y+DY
 END DO

 END SUBROUTINE IMOD_UTL_POL1DINT

 !###==================================================================
 SUBROUTINE IMOD_UTL_POL1LOCATE(XX,N,X,J)
 !###==================================================================
 !return position such that x is within xx(j) and xx(j+1)
 IMPLICIT NONE
 INTEGER,INTENT(OUT) :: J
 INTEGER,INTENT(IN) :: N
 REAL,INTENT(IN) :: X
 REAL,INTENT(IN),DIMENSION(N) :: XX
 INTEGER :: JL,JM,JU

 JL=0
 JU=N+1
 DO
  IF(JU-JL.GT.1)THEN
   JM=(JU+JL)/2
   IF((XX(N).GT.XX(1)).EQV.(X.GT.XX(JM)))THEN
    JL=JM
   ELSE
    JU=JM
   ENDIF
  ELSE
   EXIT
  ENDIF
 ENDDO

 J=JL

 END SUBROUTINE IMOD_UTL_POL1LOCATE

 !###===================================================================
 SUBROUTINE IMOD_UTL_OSSYSTEM()
 !###===================================================================
 IMPLICIT NONE
 INTEGER :: VOS,OSD_GET_OS

! !#capsim/metaswap/none active?
! CALL GETSIMGROID(ISIMGRO)

!#get operating system
! VOS=OSD_GET_OS()
! OS =0
! IF(VOS.EQ.3)OS=1
! IF(VOS.EQ.2)OS=2
! IF(VOS.EQ.4)OS=2

 OS=1

 SELECT CASE (OS)
  !## dos
  CASE (1)
   OSN(OS)   ='DOS-mode'
  !## linux/unix (beowulf)
  CASE (2)
   OSN(OS)   ='UNIX/LINUX-mode'
  !## something different
  CASE DEFAULT
   CALL IMOD_UTL_PRINTTEXT('No proper operating system!',2)
 END SELECT

 END SUBROUTINE IMOD_UTL_OSSYSTEM

 !###===================================================================
 SUBROUTINE IMOD_UTL_PRINTTEXT(TXT,TXTTYPE)
 !###===================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: TXT
 INTEGER,INTENT(IN) :: TXTTYPE
 LOGICAL :: LEX
 INTEGER :: IU

 SELECT CASE (TXTTYPE)
 !#file
  CASE (0)
   WRITE(*,'(A)') TRIM(TXT)
 !#information
  CASE (-1,1)
   WRITE(*,'(A)') TRIM(TXT)
   IF(IFLAG(1).EQ.1)PAUSE
 !#error
  CASE (2)
   WRITE(*,'(A)')
   WRITE(*,'(A)') 'Error occured!'
   WRITE(*,'(A)') TRIM(TXT)
   IF(IFLAG(1).EQ.1)PAUSE
  CASE DEFAULT
   WRITE(*,'(A)') TRIM(TXT)
   IF(IFLAG(1).EQ.1)PAUSE
 END SELECT

 IU=IUOUT
! IF(TXTTYPE.EQ.-1)IU=IUIROUT

 IF(IU.GT.0)THEN
  INQUIRE(UNIT=IU,OPENED=LEX)
  IF(LEX)THEN
   WRITE(IU,'(A)') TRIM(TXT)
   CALL FLUSH(IU)
  ENDIF
 ENDIF

 IF(TXTTYPE.EQ.2)CALL EXIT(1)

 END SUBROUTINE IMOD_UTL_PRINTTEXT

 !###====================================================================
 REAL FUNCTION IMOD_UTL_GETMOSTFREQ(FREQ,MFREQ,NFREQ)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: MFREQ,NFREQ
 REAL,DIMENSION(MFREQ),INTENT(IN) :: FREQ
 INTEGER :: I,MI,NI

 NI=1  !number of unique
 MI=NI !max. number of unique
 IMOD_UTL_GETMOSTFREQ=FREQ(NI)

 DO I=2,NFREQ
  IF(FREQ(I).NE.FREQ(I-1))THEN
   IF(NI.GT.MI)THEN
    IMOD_UTL_GETMOSTFREQ=FREQ(I-1)
    MI=NI
   ENDIF
   NI=1
  ELSE
   NI=NI+1
  ENDIF
 END DO
 !test final
 IF(NI.GT.MI) IMOD_UTL_GETMOSTFREQ=FREQ(NFREQ)
 
 END FUNCTION IMOD_UTL_GETMOSTFREQ
 
 !###======================================================================
 INTEGER FUNCTION GETUNIT()
 !###======================================================================
 IMPLICIT NONE
 LOGICAL :: LEX

 DO GETUNIT=20,5000
  INQUIRE(UNIT=GETUNIT,OPENED=LEX)
  IF(.NOT.LEX)EXIT
 END DO

 IF(GETUNIT.GT.5000)THEN
  WRITE(*,*) 'Can not open more than 500 files simultaneously!'
  GETUNIT=0
 ENDIF

 END FUNCTION GETUNIT

! !###====================================================================
! INTEGER FUNCTION JD(YEAR,MONTH,DAY)
! !###====================================================================
! !EXTRACTED FROM THE INTERNET: http://aa.usno.navy.mil/faq/docs/JD_Formula.html
! !COMPUTES THE JULIAN DATE (JD) GIVEN A GREGORIAN CALENDAR DATE (YEAR,MONTH,DAY).
! !EXAMPLE: YEAR=1970,MONTH=1,DAY=1,JD=2440588
! IMPLICIT NONE
! INTEGER,INTENT(IN) :: YEAR,MONTH,DAY
! INTEGER            :: I,J,K
!
! I =YEAR
! J =MONTH
! K =DAY
! JD=K-32075+1461*(I+4800+(J-14)/12)/4+367*(J-2-(J-14)/12*12) &
!    /12-3*((I+4900+(J-14)/12)/100)/4
!
! END FUNCTION JD

 !###======================================================================
 INTEGER FUNCTION UTL_IDFGETDATE(IDFNAME)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: IDFNAME
 INTEGER :: IOS
 INTEGER :: I,J,N!,IY,IM,ID

 !## initially no data
 UTL_IDFGETDATE=0

 !## find 8 numbers after eachother ...
 N=0
 !## start after last "\"-symbol
 DO I=INDEX(IDFNAME,'\',.TRUE.)+1,LEN_TRIM(IDFNAME)
  SELECT CASE (ICHAR(IDFNAME(I:I)))
   CASE (48:57)
    !## count numbers
    N=N+1
    !## stop if 8
    IF(N.EQ.8)EXIT
    !## mark first position
    IF(N.EQ.1)J=I
   CASE DEFAULT
    N=0
  END SELECT
 END DO

 IF(N.LT.8)RETURN

 READ(IDFNAME(J:),'(I8)',IOSTAT=IOS) UTL_IDFGETDATE
 IF(IOS.NE.0)UTL_IDFGETDATE=0

 END FUNCTION UTL_IDFGETDATE

 !###====================================================================
 INTEGER FUNCTION IDATETOJDATE(IDATE)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IDATE
 INTEGER :: IY,IM,ID

 CALL IMOD_UTL_IDATETOGDATE(IDATE,IY,IM,ID)
 IDATETOJDATE=IMOD_UTL_JD(IY,IM,ID)

 END FUNCTION IDATETOJDATE

 !###====================================================================
 SUBROUTINE IMOD_UTL_IDATETOGDATE(IDATE,IY,IM,ID)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IDATE
 INTEGER,INTENT(OUT) :: IY,IM,ID
 CHARACTER(LEN=8)   :: CDATE

 IY = IDATE / 10000
 IM = MOD( IDATE, 10000 ) / 100
 ID = MOD( IDATE, 100 )

 END SUBROUTINE IMOD_UTL_IDATETOGDATE

 !###======================================================================
 SUBROUTINE IMOD_UTL_FILLARRAY(IP,NP,B)
 !###======================================================================
 !# read binair number (e.g. 256) and returns array (/1,0,0,1,0,0,1/)
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NP
 INTEGER,INTENT(IN) :: B
 INTEGER,INTENT(OUT),DIMENSION(NP) :: IP
 INTEGER :: I,BB

 IP=0
 BB=B
 DO I=1,NP
  IP(I)=MOD(BB,2)
  BB=BB/2
 END DO

 !## make sure results are only 0/1 values
 DO I=1,NP
  IF(IP(I).LT.0.OR.IP(I).GT.1)IP(I)=0
 END DO

 END SUBROUTINE IMOD_UTL_FILLARRAY

 !###======================================================================
 SUBROUTINE IMOD_UTL_READARRAY(IP,NP,B)
 !###======================================================================
 !# write a binair-number given an array (/1,0,0,4,0,0,7/)
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NP
 INTEGER,INTENT(OUT) :: B
 INTEGER,INTENT(IN),DIMENSION(NP) :: IP
 INTEGER :: I,J

 B=0
 DO I=1,NP
  J=MAX(0,MIN(IP(I),1))
  B=B+(J*(2**(I-1)))
 END DO

 END SUBROUTINE IMOD_UTL_READARRAY

!###====================================================================
 FUNCTION IMOD_UTL_SUBST(FNAME,SUB1,SUB2)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: SUB1,SUB2
 CHARACTER(LEN=*),INTENT(IN) :: FNAME
 INTEGER :: I,J
 CHARACTER(LEN=256) :: IMOD_UTL_SUBST

 IMOD_UTL_SUBST=FNAME

 I=INDEX(FNAME,SUB1)
 IF(I.EQ.0)RETURN
 I=I-1
 J=I+LEN(SUB1)+1

 IMOD_UTL_SUBST=FNAME(:I)//TRIM(SUB2)//FNAME(J:)

 END FUNCTION IMOD_UTL_SUBST 

 !###======================================================================
 LOGICAL FUNCTION IMOD_UTL_DIRINFO(DIR,WC,LISTNAME,FT)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR,WC,FT
 CHARACTER(LEN=*),INTENT(OUT),DIMENSION(:),POINTER :: LISTNAME
 CHARACTER(LEN=256),DIMENSION(:),POINTER :: C_LISTNAME
 CHARACTER(LEN=256) :: LINE
 INTEGER :: IU,I,J,N,IOS
 LOGICAL :: LEX

 IMOD_UTL_DIRINFO=.FALSE.
 
 IF(LEN(C_LISTNAME).LT.LEN(LISTNAME))CALL IMOD_UTL_PRINTTEXT('c_listname()<listname()',2)
 
 IU=IMOD_UTL_GETUNIT()
 INQUIRE(FILE='.\dir_imod.txt',EXIST=LEX)
 IF(LEX)THEN
  OPEN(IU,FILE='.\dir_imod.txt',ACTION='READ',FORM='FORMATTED',IOSTAT=IOS)
  IF(IOS.NE.0)CALL IMOD_UTL_PRINTTEXT('iMOD does not have priveleges to delete [.\dir_imod.txt]',2)
  CLOSE(IU,STATUS='DELETE',IOSTAT=IOS)
  IF(IOS.NE.0)CALL IMOD_UTL_PRINTTEXT('iMOD does not have priveleges to delete [.\dir_imod.txt]',2)
 ENDIF

 IU=IMOD_UTL_GETUNIT()
 OPEN(IU,FILE='.\dir.bat',ACTION='WRITE',FORM='FORMATTED',IOSTAT=IOS)
 IF(IOS.NE.0)CALL IMOD_UTL_PRINTTEXT('iMOD does not have priveleges to create: [.\dir_imod.bat]',2)
 
 IF(FT.EQ.'F'.OR.FT.EQ.'f')LINE='dir /b /o "'//TRIM(DIR)//'\'//TRIM(WC)//'" > "'//'.\dir_imod.txt"'
 IF(FT.EQ.'D'.OR.FT.EQ.'d')LINE='dir /ad /b /o "'//TRIM(DIR)//'\'//TRIM(WC)//'" > ".\dir_imod.txt"'

 !## remove \\
 DO
  I=INDEX(LINE,'\\')
  IF(I.EQ.0)EXIT
  LINE(I+1:256-1)=LINE(I+2:)
 ENDDO

 WRITE(IU,'(A)') TRIM(LINE)
 CLOSE(IU)

 LINE='.\dir.bat'
 CALL SYSTEM(TRIM(LINE))

 IU=IMOD_UTL_GETUNIT()
 OPEN(IU,FILE='.\dir_imod.txt',ACTION='READ',FORM='FORMATTED')
 IF(IOS.NE.0)CALL IMOD_UTL_PRINTTEXT('iMOD does not have priveleges to read: [.\dir_imod.txt]',2)

 ALLOCATE(C_LISTNAME(50))
 
 I=0
 DO 
  READ(IU,'(A256)',IOSTAT=IOS) LINE
  IF(IOS.NE.0)EXIT
  J=LEN_TRIM(LINE)
  IF(J.EQ.0)EXIT
  LINE(2:J+1)=LINE(1:J)
  LINE(1:1)='"'
  LINE(J+2:J+2)='"'
  I=I+1
  IF(I.GT.SIZE(C_LISTNAME))THEN
   N=SIZE(C_LISTNAME)
   ALLOCATE(LISTNAME(N));  LISTNAME(1:N)=C_LISTNAME(1:N)
   DEALLOCATE(C_LISTNAME); ALLOCATE(C_LISTNAME(N*2))
   C_LISTNAME(1:N)=LISTNAME(1:N); DEALLOCATE(LISTNAME)
  ENDIF
  READ(LINE,*,IOSTAT=IOS) C_LISTNAME(I)
  IF(IOS.NE.0)EXIT
 END DO

 CLOSE(IU)!,STATUS='DELETE')
 
 N=I 
 
 ALLOCATE(LISTNAME(N))
 LISTNAME(1:N)=C_LISTNAME(1:N)
 DEALLOCATE(C_LISTNAME)
 
 IMOD_UTL_DIRINFO=.TRUE.
 
 END FUNCTION IMOD_UTL_DIRINFO

 !###====================================================================
 REAL FUNCTION UTL_GETMOSTFREQ(FREQ,MFREQ,NFREQ)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: MFREQ,NFREQ
 REAL,DIMENSION(MFREQ),INTENT(IN) :: FREQ
 INTEGER :: I,MI,NI

 NI=1  !number of unique
 MI=NI !max. number of unique
 UTL_GETMOSTFREQ=FREQ(NI)

 DO I=2,NFREQ
  IF(FREQ(I).NE.FREQ(I-1))THEN
   IF(NI.GT.MI)THEN
    UTL_GETMOSTFREQ=FREQ(I-1)
    MI=NI
   ENDIF
   NI=1
  ELSE
   NI=NI+1
  ENDIF
 END DO
 !test final
 IF(NI.GT.MI) UTL_GETMOSTFREQ=FREQ(NFREQ)

 END FUNCTION UTL_GETMOSTFREQ
 
 !###====================================================
 SUBROUTINE UTL_GETUNIQUE_INT(IX,N,NU,NODATA)
 !###====================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: N
 INTEGER,INTENT(OUT) :: NU
 INTEGER,INTENT(INOUT),DIMENSION(N) :: IX
 INTEGER,INTENT(IN),OPTIONAL :: NODATA
 INTEGER :: I

 CALL SHELLSORT_INT(N,IX)

 !## determine number of unique classes
 IF(PRESENT(NODATA))THEN
  NU=0
  DO I=1,N
   IF(NU.EQ.0)THEN
    IF(IX(I).NE.NODATA)THEN
     NU=NU+1
     IX(NU)=IX(I)
    ENDIF
   ELSE
    IF(IX(I).NE.IX(NU).AND.IX(I).NE.NODATA)THEN
     NU    =NU+1
     IX(NU)=IX(I)
    ENDIF
   ENDIF
  END DO
 ELSE 
  !## determine number of unique classes
  NU=1
  DO I=2,N
   IF(IX(I).NE.IX(NU))THEN
    NU    =NU+1
    IX(NU)=IX(I)
   ENDIF
  END DO
 ENDIF
 
 END SUBROUTINE UTL_GETUNIQUE_INT
 
 !###====================================================
 SUBROUTINE SHELLSORT_INT(N,A)
 !###====================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: N
 INTEGER,DIMENSION(N) :: A
 INTEGER :: I,J,INC
 INTEGER :: V

 INC=1
 1 INC=3*INC+1
 IF(INC.LE.N)GOTO 1
  2 CONTINUE
  INC=INC/3
  DO I=INC+1,N
   V=A(I)
   J=I
   3 IF(A(J-INC).GT.V)THEN
    A(J)=A(J-INC)
    J=J-INC
   IF(J.LE.INC)GOTO 4
    GOTO 3
   ENDIF
   4  A(J)=V
 END DO
 IF(INC.GT.1)GOTO 2

 RETURN
 END SUBROUTINE
 
END MODULE IMOD_UTL