C     ******************************************************************
C     COMMON subroutines for all WLmodel program
C     ******************************************************************
c  Program  T-COMP_Create.f   ---   Creates comparable radial models and batch file to run all.
c
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
c ---------------------------------------------------------------------------------
      function rGET(io,sNOL,sNOR,ierr)
      IMPLICIT REAL*8(A-H,O-Z),INTEGER*4(I-N)
      include 'WLmodel.inc'
      character*5   sNOR
      character*5   sNOL
      CHARACTER*2048 sTxT
      INTEGER ierr
      INTEGER io
      real*8 rn(lrna)
c
      rGET = -1.0E30 
      call ncread(io,sTxT,sNOL,sNOR,ierr)
      if( ierr.eq.0 ) then
        sTxT = sTxT(index(sTxT,'=')+1:len(sTxT))
        call qread(rn,1,sTxT,ierr)
        if( ierr.eq.0 ) rGET = rn(1)
      endif  
c
      return
      end
c ---------------------------------------------------------------------------------
      subroutine sGET(io,sNOL,sNOR,ierr, sTAG, sTxOUT)
      CHARACTER sTxOUT*(*)
      include 'WLmodel.inc'
      character*5   sNOR
      character*5   sNOL
      character*(*)  sTAG
      CHARACTER*2048 sTxT
      INTEGER ierr
      INTEGER io
      integer ki
      integer n
c
      sTxOUT = ""
      
      call ncread(io,sTxT,sNOL,sNOR,ierr)
      if( ierr.eq.0 ) then
        n = Len( trim(sTAG) )  
        ki = index(sTxT,sTAG(1:n))
        sTxOUT = sTxT(n+ki:Len(sTxT))
      endif  
c
      return
      end
c ---------------------------------------------------------------------------------
      subroutine DelimSET(io, sNOL, sNOR, sVAR )
c
      include 'WLmodel.inc'
      real*8 rn(lrna)
      character*5   sNOR
      character*5   sNOL
      character*5   sVAR
      character*2048 txt
      integer io 
      iMAX = 5
      sNOL = '.'
      sNOR = '!'
      sVAR = '.'
c
c   Check if delimiters are to be redefined       
      do i = 1, 3
        read(io,'(a)',end=10) txt
        call UPCASE(txt)
        call tab2space(txt)
        k1 = index(txt,'NO-LINE_DELIMITER:')
        if( k1.gt.0 ) then
          k1 = k1 + Len('NO-LINE_DELIMITER:') 
	    sNOL = txt(k1:k1+iMAX-1) 
          k1 = index(sNOL,' ')
          if( k1.gt.0 ) sNOL(k1:iMAX) = '      '
	  endif
        k1 = index(txt,'NO-RIGHT_DELIMITER:')
        if( k1.gt.0 ) then
          k1 = k1 + Len('NO-RIGHT_DELIMITER:') 
	    sNOR = txt(k1:k1+iMAX-1)  
          k1 = index(sNOR,' ')
          if( k1.gt.0 ) sNOR(k1:iMAX) = '      '
	  endif
        k1 = index(txt,'VARIABLE_DELIMITER:')
        if( k1.gt.0 ) then
          k1 = k1 + Len('VARIABLE_DELIMITER:') 
	    sVAR = txt(k1:k1+iMAX-1)  
          k1 = index(sVAR,' ')
          if( k1.gt.0 ) sVAR(k1:iMAX) = '      '
	  endif
      enddo  
  10  rewind(io)
c
      return
      end  
c ---------------------------------------------------------------------------------
c
      subroutine sSUBstring(sTEMP,sNEW, sVAR, sTxOUT)
      CHARACTER*2048 sTEMP
      CHARACTER*2048 sWORK
      CHARACTER*2048 sADD
      character*64 sNEW
      CHARACTER*(*) sTxOUT
      character*5  sVAR
      integer iMax
      integer ki
      integer ki2
      integer n
c
      sWORK = sTEMP
      n = Len(trim(sVAR))
      ki = index(sWORK,sVAR(1:n))
      if( ki.gt.0 ) then
        sWORK(ki:ki) = ' '
        sADD = sTEMP(1:ki-1) // sNEW
        ke = index(sWORK,sVAR(1:n))
        n = Len(trim(sWORK))
        if( ke.gt.0 ) then
          sTxOUT = trim(sADD) // sTEMP(ke+1:n)
        else  
          sTxOUT = trim(sNEW) // sTEMP(ki:n) 
        endif  
      else  
        sTxOUT = ""
      endif  
c
      return
      end
c ---------------------------------------------------------------------------------
	integer function iMATCHs(sFIND, sARRlook, nLOOK)
      include 'WLmodel.inc'
      CHARACTER*32 sFIND
      CHARACTER*32 sARRlook(nMAXser)
      integer nLOOK
      integer i
      integer n
c
      iMATCHs = 0
      i = 0
      n = len(trim(sFIND))
      do while (i < nLOOK) 
        i = i+1
        if( sFIND(1:n).eq.sARRlook(i)(1:n) ) then
          iMATCHs = i
          i = nLOOK 
        endif
      end do
c
      return
	end
c ---------------------------------------------------------------------------------
	integer function iMATCHr(rFIND, rARRlook, nLOOK, iDIRin)
      include 'WLmodel.inc'
      integer nLOOK
      integer i
      integer iDIR
      integer iDIRin
      real*8 rFIND
      real*8 rARRlook(ln1)
c
      if( iDIRin.lt.0 ) then 
        iDIR = -1
      else  
        iDIR = 1
      endif
c      
      iMATCHr = 0
      i = 0
      do while (i < nLOOK) 
        i = i+1
        if( rFIND*iDIR .lt. rARRlook(i)*iDIR ) then
          iMATCHr = i-1
          i = nLOOK 
        endif
      end do
c
      return
	end
c ---------------------------------------------------------------------------------
c
      function rFRCmlt(rBASE,rEXTENT,iCNT)
      IMPLICIT REAL*8(A-H,O-Z),INTEGER*4(I-N)
      real*8 rA
      real*8 rBASE
      real*8 rCLOSE
      real*8 rEXTENT
      real*8 rFRC
      real*8 rRAT
      real*8 rROOT
      integer i
      integer iCNT
      data rCLOSE /1.E-8/
c
c   Make a first cut at multiplier ...................
c
      rA = 1.00000000000
      rFRCmlt = rA
      rRAT = rEXTENT / rBASE
      if( iCNT .gt. rRAT ) return
c
      rROOT = 1. / iCNT
      rA  = dlog(rRAT)/(iCNT*2)
      rA  = exp(rA)
c
      i = 0
      rFRC = 0.000
      do while( i.lt.99 .and. abs(rFRC - 1.).gt.rCLOSE ) 
        i   = i + 1
        rFRC = ( rRAT /((1.- rA**iCNT)/(1.-rA)))**rROOT
        rA   =  rA * rFRC
      enddo
      rFRCmlt = rA
c
      return
      end
c ---------------------------------------------------------------------------------
      function dIIf(bYN,d1,d2)
      IMPLICIT REAL*8(C-H,O-Z),INTEGER*4(I-N)
      logical bYN
      real*8 d1,d2
c'
      if( bYN ) then
        diif = d1
      else
        diif = d2
      endif 
c'
      return
      end        
