utility.F90       coverage:  68.75 %func     49.15 %block


     1) module Utility_module
     2) 
     3)   use PFLOTRAN_Constants_module
     4) 
     5)   implicit none
     6) 
     7)   private
     8) 
     9) #include "petsc/finclude/petscsys.h"
    10) 
    11)   interface DotProduct
    12)     module procedure DotProduct1
    13)     module procedure DotProduct2
    14)     module procedure DotProduct3
    15)   end interface
    16)   
    17)   interface CrossProduct
    18)     module procedure CrossProduct1
    19)   end interface
    20)   
    21)   interface reallocateRealArray
    22)     module procedure reallocateRealArray1D
    23)     module procedure reallocateRealArray2D
    24)   end interface
    25)   
    26)   interface UtilityReadArray
    27)     module procedure UtilityReadIntArray
    28)     module procedure UtilityReadRealArray
    29)   end interface
    30) 
    31)   interface DeallocateArray
    32)     ! TODO(geh) replace deallocations with the below
    33)     module procedure DeallocateArray1DInteger
    34)     module procedure DeallocateArray2DInteger
    35)     module procedure DeallocateArray3DInteger
    36)     module procedure DeallocateArray1DReal
    37)     module procedure DeallocateArray2DReal
    38)     module procedure DeallocateArray3DReal
    39)     module procedure DeallocateArray1DLogical
    40)     module procedure DeallocateArray2DLogical
    41)     module procedure DeallocateArray3DLogical
    42)     module procedure DeallocateArray1DString
    43)     module procedure DeallocateArray2DString
    44)   end interface
    45)   
    46)   interface InterfaceApprox
    47)     module procedure InterfaceApproxWithDeriv
    48)     module procedure InterfaceApproxWithoutDeriv
    49)   end interface
    50) 
    51)   public :: GetRndNumFromNormalDist, &
    52)             DotProduct, &
    53)             CrossProduct, &
    54)             reallocateRealArray, &
    55)             reallocateIntArray, &
    56)             UtilityReadArray, &
    57)             DeallocateArray, &
    58)             InterfaceApprox, &
    59)             Interpolate, &
    60)             InterpolateBilinear, &
    61)             SearchOrderedArray, &
    62)             ludcmp, &
    63)             lubksb, &
    64)             FileExists, &
    65)             Equal, &
    66)             BestFloat, &
    67)             QuadraticPolynomialSetup, &
    68)             QuadraticPolynomialEvaluate, &
    69)             CubicPolynomialSetup, &
    70)             CubicPolynomialEvaluate, &
    71)             ConvertMatrixToVector, &
    72)             Kron, &
    73)             Transposer, &
    74)             Determinant, &
    75)             InterfaceApproxWithDeriv, &
    76)             InterfaceApproxWithoutDeriv, &
    77)             PrintProgressBarInt
    78)             
    79) contains
    80) 
    81) ! ************************************************************************** !
    82) 
    83) function rnd()
    84) 
    85)   implicit none
    86) 
    87)   integer*8, save :: iseed = 1
    88)   PetscReal :: rnd
    89) 
    90)   iseed = iseed*125
    91)   iseed = iseed - (iseed/2796203) * 2796203
    92)   rnd   = iseed/2796203.0
    93)   return
    94) end function rnd
    95) 
    96) ! ************************************************************************** !
    97) 
    98) function ran1(idum)
    99)       
   100)   implicit none
   101)       
   102)   save
   103) 
   104) !-----returns a random number in the range (0,1). Set idum to neg.
   105) !     value to initialize
   106) 
   107)   PetscReal :: ran1
   108)   PetscReal :: r(97),rm1,rm2
   109)   PetscInt :: idum,iff,ix1,ix2,ix3,j,m1,ia1,ic1,m2,ia2,ic2,m3,ia3,ic3
   110) 
   111)   parameter (M1  = 259200)
   112)   parameter (IA1 = 7141)
   113)   parameter (IC1 = 54773)
   114)   parameter (RM1 = 1.0/M1)
   115)   parameter (M2  = 134456)
   116)   parameter (IA2 = 8121)
   117)   parameter (IC2 = 28411)
   118)   parameter (RM2 = 1.0/M2)
   119)   parameter (M3  = 243000)
   120)   parameter (IA3 = 4561)
   121)   parameter (IC3 = 51349)
   122) 
   123)   data iff/0/
   124) 
   125)   if (idum.lt.0 .or. iff.eq.0) then
   126)     iff=1
   127)     ix1=mod(IC1-idum,M1)
   128)     ix1=mod(IA1*ix1+IC1,M1)
   129)     ix2=mod(ix1,M2)
   130)     ix1=mod(IA1*ix1+IC1,M1)
   131)     ix3=mod(ix1,M3)
   132)     do j=1,97
   133)       ix1=mod(IA1*ix1+IC1,M1)
   134)       ix2=mod(IA2*ix2+IC2,M2)
   135)       r(j)=(float(ix1)+float(ix2)*RM2)*RM1
   136)     enddo
   137)     idum=1
   138)   endif
   139)   ix1=mod(IA1*ix1+IC1,M1)
   140)   ix2=mod(IA2*ix2+IC2,M2)
   141)   ix3=mod(IA3*ix3+IC3,M3)
   142)   j=1+(97*ix3)/M3
   143) !  if (j.gt.97 .or. j.lt.1) pause
   144) 
   145)   ran1=r(j)
   146)   r(j)=(float(ix1)+float(ix2)*RM2)*RM1
   147)       
   148)   return
   149) end function ran1
   150) 
   151) ! ************************************************************************** !
   152) 
   153) function ran2(idum)
   154)       
   155)   implicit none
   156) 
   157) !-----Minimal random number generator of Park and Miller 
   158) !     in the range (0,1)
   159) 
   160)   PetscReal :: ran2, AM, EPS, RNMX, temp
   161)   PetscInt :: IA, IM, IQ, IR, NTAB, idum, iy, j, k, iv(32), NDIV
   162) 
   163)   parameter (IA = 16807)
   164)   parameter (IM = 2147483647)
   165)   parameter (AM = 1.0/IM)
   166)   parameter (IQ = 127773)
   167)   parameter (IR = 2836)
   168)   parameter (NTAB = 32)
   169)   parameter (NDIV = 1+(IM-1)/NTAB)
   170)   parameter (EPS  = 1.2e-7)
   171)   parameter (RNMX = 1.0-EPS)
   172) 
   173)   !dimension iv(NTAB)
   174) 
   175)   iy = 0
   176)   if (idum.le.0 .or. iy.eq.0) then
   177)     if (-idum .lt. 1) then
   178)       idum = 1
   179)     else 
   180)       idum = -idum
   181)     endif
   182)     do j = NTAB+7,0,-1
   183)       k = idum/IQ
   184)       idum = IA*(idum-k*IQ)-IR*k
   185)       if (idum .lt. 0) idum = idum+IM
   186)       if (j .lt. NTAB) iv(j) = idum
   187)     enddo
   188)     iy = iv(1)
   189)   endif
   190)   k = idum/IQ
   191)   idum = IA*(idum-k*IQ)-IR*k
   192)   if (idum .lt. 0) idum = idum+IM
   193)   j= iy/NDIV
   194)   iy = iv(j)
   195)   iv(j) = idum
   196)   temp = AM*iy
   197)   if (temp .gt. RNMX) then
   198)     ran2 = RNMX
   199)   else 
   200)     ran2 = temp
   201)   endif
   202) 
   203)   return
   204) end function ran2
   205) 
   206) ! ************************************************************************** !
   207) 
   208) subroutine GetRndNumFromNormalDist(mean,st_dev,number)
   209)   ! 
   210)   ! Generates a random number that is normally distributed, as defined by the
   211)   ! mean and standard deviation given. This subroutine uses the Box-Muller
   212)   ! transform.
   213)   ! G. E. P. Box and M. E. Muller (1958), A note on the generation of random
   214)   ! normal deviates, The Annals of Mathematical Statistics, Vol. 29, No. 2,
   215)   ! pp. 610-611.
   216)   ! 
   217)   ! Author: Jenn Frederick
   218)   ! Date: 2/12/2016
   219) 
   220)   implicit none
   221)   
   222)   PetscReal :: mean, st_dev, number
   223) 
   224)   PetscBool, save :: switch
   225)   PetscReal, save :: z0, z1
   226)   PetscReal :: u1, u2
   227)   PetscReal :: TWO_PI
   228) 
   229)   switch = .not.switch
   230)   TWO_PI = 2*3.14159265358979323846264338327950288419716939937510582
   231) 
   232)   if (.not.switch) then
   233) 
   234)     ! Generate two random numbers between (0,1)
   235)     u1 = rnd()
   236)     u2 = rnd()
   237)     
   238)     z0 = sqrt(-2.0*log(u1)) * cos(TWO_PI*u2)
   239)     z1 = sqrt(-2.0*log(u1)) * sin(TWO_PI*u2) 
   240)     
   241)     number = z0*st_dev + mean
   242) 
   243)   else
   244)     
   245)     number = z1*st_dev + mean
   246) 
   247)   endif
   248) 
   249) end subroutine GetRndNumFromNormalDist
   250) ! ************************************************************************** !
   251) 
   252) subroutine Natural2LocalIndex(ir, nl, llist, llength)
   253)   implicit none
   254)   PetscInt :: nl, ir,na, l_search, itt, llength
   255)   PetscInt :: llist(*)
   256)   
   257)   PetscInt ::  nori0, nori1, nori
   258)   
   259)   
   260)   nl=-1
   261)   l_search = llength
   262)   
   263)   na = ir!-1 
   264)   itt=0
   265)   nori0 =1
   266)   nori1 = llength
   267)   if (na>=llist(1) .and. na <= llist(llength))then
   268)   do while(l_search > 1 .and.itt<=50)
   269)   
   270)     itt=itt+1
   271)     if (na == llist(nori0))then
   272)       nl = nori0
   273)       exit
   274)     elseif (na == llist(nori1))then
   275)        nl = nori1
   276)       exit
   277)     endif   
   278)      
   279)      ! nori = int((real(nori0 + nori1))/ 2.) + mod ( nori0 + nori1,2 )
   280)     nori =  int(floor(real(nori0+nori1)/2D0 + .75D0))
   281)     if ( na > llist(nori)) then
   282)       nori0 = nori
   283)     elseif (na < llist(nori))then
   284)       nori1 = nori
   285)     else
   286)       if (na == llist(nori))then
   287)         nl = nori
   288)         exit
   289)       else
   290)         print *, 'wrong index', na, nori, llist(nori); stop
   291)       endif  
   292)     endif
   293)     l_search = nori1-nori0
   294)     if (itt>=40)then
   295)       print *, na, nori0,nori1,nori, llist(nori0), llist(nori1)
   296)       if (itt>=50) stop
   297)     endif
   298)   enddo  
   299)  endif         
   300)           
   301) end subroutine Natural2LocalIndex
   302) 
   303) ! ************************************************************************** !
   304) 
   305) subroutine reallocateIntArray(array,size)
   306)   ! 
   307)   ! Reallocates an integer array to a larger size and copies
   308)   ! 
   309)   ! Author: Glenn Hammond
   310)   ! Date: 10/29/07
   311)   ! 
   312) 
   313)   implicit none
   314) 
   315)   PetscInt, pointer :: array(:)
   316)   PetscInt :: size
   317)   
   318)   PetscInt, allocatable :: array2(:)
   319)   
   320)   allocate(array2(size))
   321)   array2(1:size) = array(1:size)
   322)   deallocate(array)
   323)   allocate(array(2*size))
   324)   array = 0
   325)   array(1:size) = array2(1:size)
   326)   size = 2*size
   327)   deallocate(array2)
   328) 
   329) end subroutine reallocateIntArray
   330) 
   331) ! ************************************************************************** !
   332) 
   333) subroutine reallocateRealArray1D(array,size)
   334)   ! 
   335)   ! reallocateRealArray2D: Reallocates a 2D real array to a larger size and
   336)   ! copies values over.
   337)   ! 
   338)   ! Author: Glenn Hammond
   339)   ! Date: 10/29/07, 10/03/13
   340)   ! 
   341) 
   342)   implicit none
   343) 
   344)   PetscReal, pointer :: array(:)
   345)   PetscInt :: size
   346)   
   347)   PetscReal, allocatable :: array2(:)
   348)   
   349)   allocate(array2(size))
   350)   array2(1:size) = array(1:size)
   351)   deallocate(array)
   352)   allocate(array(2*size))
   353)   array = 0.d0
   354)   array(1:size) = array2(1:size)
   355)   size = 2*size
   356)   deallocate(array2)
   357) 
   358) end subroutine reallocateRealArray1D
   359) 
   360) ! ************************************************************************** !
   361) 
   362) subroutine reallocateRealArray2D(array,rank2_size)
   363)   ! 
   364)   ! Reallocates a 2D real array to a larger size in last
   365)   ! dimension and copies values over.
   366)   ! 
   367)   ! Author: Glenn Hammond
   368)   ! Date: 10/03/13
   369)   ! 
   370) 
   371)   implicit none
   372) 
   373)   PetscReal, pointer :: array(:,:)
   374)   PetscInt :: rank1_size, rank2_size
   375)   
   376)   PetscReal, allocatable :: array2(:,:)
   377)   
   378)   rank1_size = size(array,1)
   379)   allocate(array2(rank1_size,rank2_size))
   380)   array2(:,1:rank2_size) = array(:,1:rank2_size)
   381)   deallocate(array)
   382)   allocate(array(rank1_size,2*rank2_size))
   383)   array = 0.d0
   384)   array(:,1:rank2_size) = array2(:,1:rank2_size)
   385)   rank2_size = 2*rank2_size
   386)   deallocate(array2)
   387) 
   388) end subroutine reallocateRealArray2D
   389) 
   390) ! ************************************************************************** !
   391) 
   392) subroutine ludcmp(A,N,INDX,D)
   393)   ! 
   394)   ! Given an NxN matrix A, with physical dimension NP, this routine replaces it
   395)   ! by the LU decomposition of a rowwise permutation of itself.
   396)   ! A and N are input. A is output; INDX is output vector which records the
   397)   ! row permutation effected by the partial pivoting; D id output as +1 or -1
   398)   ! depending on whether the number of row interchanges was odd or even,
   399)   ! respectively. This routine is used in combination with lubksb to solve
   400)   ! linear equations or invert a matrix.
   401)   ! 
   402) 
   403)   implicit none
   404) 
   405)   PetscInt :: N
   406)   PetscReal, parameter :: tiny=1.0d-20
   407)   PetscReal :: A(N,N),VV(N)
   408)   PetscInt :: INDX(N)
   409)   PetscInt :: D
   410) 
   411)   PetscInt :: i, j, k, imax
   412)   PetscReal :: aamax, sum, dum
   413)   PetscMPIInt ::  rank
   414)   PetscErrorCode :: ierr
   415) 
   416)   D=1
   417)   do i=1,N
   418)     aamax=0.d0
   419)     do j=1,N
   420)       if (abs(A(i,j)).gt.aamax) aamax=abs(A(i,j))
   421)     enddo
   422)     if (aamax <= 0.d0) then
   423)       call MPI_Comm_rank(MPI_COMM_WORLD,rank,ierr)
   424)       print *, "ERROR: Singular value encountered in ludcmp() on processor: ", rank, ' aamax = ',aamax,' row = ',i
   425)       do k = 1, N
   426)         print *, "Jacobian: ",k,(j,A(k,j),j=1,N)
   427)       enddo
   428)       call MPI_Abort(MPI_COMM_WORLD,ONE_INTEGER_MPI,ierr)
   429)       call MPI_Finalize(ierr)
   430)       stop
   431)     endif
   432)     VV(i)=1./aamax
   433)   enddo
   434)   do j=1,N
   435)     do i=1,j-1
   436)       sum=A(i,j)
   437)       do k=1,i-1
   438)         sum=sum-A(i,k)*A(k,j)
   439)       enddo
   440)       A(i,j)=sum
   441)     enddo
   442)     aamax=0
   443)     do i=j,N
   444)       sum=A(i,j)
   445)       do k=1,j-1
   446)         sum=sum-A(i,k)*A(k,j)
   447)       enddo
   448)       A(i,j)=sum
   449)       dum=VV(i)*abs(sum)
   450)       if (dum.ge.aamax) then
   451)         imax=i
   452)         aamax=dum
   453)       endif
   454)     enddo
   455)     if (j.ne.imax) then
   456)       do k=1,N
   457)         dum=A(imax,k)
   458)         A(imax,k)=A(j,k)
   459)         A(j,k)=dum
   460)       enddo
   461)       D=-D
   462)       VV(imax)=VV(j)
   463)     endif
   464)     INDX(j)=imax
   465)     if (A(j,j).eq.0.) A(j,j)=tiny
   466)     if (j.ne.N) then
   467)       dum=1.d0/A(j,j)
   468)       do i=j+1,N
   469)         A(i,j)=A(i,j)*dum
   470)       enddo
   471)     endif
   472)   enddo
   473)   return
   474) 
   475) end subroutine ludcmp
   476) 
   477) ! ************************************************************************** !
   478) 
   479) subroutine lubksb(A,N,INDX,B)
   480)   ! 
   481)   ! Solves the set of N linear equations A.X=D. Here A is input, not as a matrix
   482)   ! A but rather as its LU decomposition. INDX is the input as the permutation
   483)   ! vector returned by ludcmp. B is input as the right-hand side vector B, and
   484)   ! returns with the solution vector X.
   485)   ! 
   486) 
   487)   implicit none
   488) 
   489)   PetscInt :: N
   490)   PetscReal :: A(N,N),B(N)
   491)   PetscInt :: INDX(N)
   492) 
   493)   PetscInt :: i, j, ii, ll
   494)   PetscReal :: sum
   495) 
   496) 
   497)   ii=0
   498)   do i=1,N
   499)     ll=INDX(i)
   500)     sum=B(ll)
   501)     B(ll)=B(i)
   502)     if (ii.ne.0) then
   503)       do j=ii,i-1
   504)         sum=sum-A(i,j)*B(j)
   505)       enddo
   506)     else if (sum.ne.0) then
   507)       ii=i
   508)     endif
   509)     B(i)=sum
   510)   enddo
   511)   do i=N,1,-1
   512)     sum=B(i)
   513)     if (i.lt.N) then
   514)       do j=i+1,N
   515)         sum=sum-A(i,j)*B(j)
   516)       enddo
   517)     endif
   518)     B(i)=sum/A(i,i)
   519)   enddo
   520)   return
   521) 
   522) end subroutine lubksb
   523) 
   524) ! ************************************************************************** !
   525) 
   526) subroutine ludcmp_chunk(A,N,INDX,D,chunk_size,ithread,num_threads)
   527)   ! 
   528)   ! Given an NxN matrix A, with physical dimension NP, this routine replaces it
   529)   ! by the LU decomposition of a rowwise permutation of itself.
   530)   ! A and N are input. A is output; INDX is output vector which records the
   531)   ! row permutation effected by the partial pivoting; D id output as +1 or -1
   532)   ! depending on whether the number of row interchanges was odd or even,
   533)   ! respectively. This routine is used in combination with lubksb to solve
   534)   ! linear equations or invert a matrix.
   535)   ! 
   536) 
   537)   implicit none
   538) 
   539)   PetscInt :: N
   540)   PetscInt :: chunk_size
   541)   PetscInt :: num_threads
   542)   PetscReal, parameter :: tiny=1.0d-20
   543)   PetscReal :: A(chunk_size,num_threads,N,N),VV(chunk_size,num_threads,N)
   544)   PetscInt :: INDX(chunk_size,num_threads,N)
   545)   PetscInt :: D(chunk_size,num_threads)
   546)   PetscInt :: ithread
   547) 
   548)   PetscInt :: i, j, k, imax
   549)   PetscReal :: aamax, sum, dum
   550)   PetscMPIInt ::  rank
   551)   PetscErrorCode :: ierr
   552)   
   553)   PetscInt :: ichunk
   554) 
   555)   do ichunk = 1, chunk_size
   556) 
   557)   D(ichunk,ithread)=1
   558)   do i=1,N
   559)     aamax=0
   560)     do j=1,N
   561)       if (abs(A(ichunk,ithread,i,j)).gt.aamax) aamax=abs(A(ichunk,ithread,i,j))
   562)     enddo
   563)     if (aamax.eq.0) then
   564)       call MPI_Comm_rank(MPI_COMM_WORLD,rank,ierr)
   565)       print *, "ERROR: Singular value encountered in ludcmp() on processor", rank, ichunk,ithread
   566)       call MPI_Abort(MPI_COMM_WORLD,ONE_INTEGER_MPI,ierr)
   567)       call MPI_Finalize(ierr)
   568)       stop
   569)     endif
   570)     VV(ichunk,ithread,i)=1./aamax
   571)   enddo
   572)   do j=1,N
   573)     do i=1,j-1
   574)       sum=A(ichunk,ithread,i,j)
   575)       do k=1,i-1
   576)         sum=sum-A(ichunk,ithread,i,k)*A(ichunk,ithread,k,j)
   577)       enddo
   578)       A(ichunk,ithread,i,j)=sum
   579)     enddo
   580)     aamax=0
   581)     do i=j,N
   582)       sum=A(ichunk,ithread,i,j)
   583)       do k=1,j-1
   584)         sum=sum-A(ichunk,ithread,i,k)*A(ichunk,ithread,k,j)
   585)       enddo
   586)       A(ichunk,ithread,i,j)=sum
   587)       dum=VV(ichunk,ithread,i)*abs(sum)
   588)       if (dum.ge.aamax) then
   589)         imax=i
   590)         aamax=dum
   591)       endif
   592)     enddo
   593)     if (j.ne.imax) then
   594)       do k=1,N
   595)         dum=A(ichunk,ithread,imax,k)
   596)         A(ichunk,ithread,imax,k)=A(ichunk,ithread,j,k)
   597)         A(ichunk,ithread,j,k)=dum
   598)       enddo
   599)       D(ichunk,ithread)=-D(ichunk,ithread)
   600)       VV(ichunk,ithread,imax)=VV(ichunk,ithread,j)
   601)     endif
   602)     INDX(ichunk,ithread,j)=imax
   603)     if (A(ichunk,ithread,j,j).eq.0.) A(ichunk,ithread,j,j)=tiny
   604)     if (j.ne.N) then
   605)       dum=1./A(ichunk,ithread,j,j)
   606)       do i=j+1,N
   607)         A(ichunk,ithread,i,j)=A(ichunk,ithread,i,j)*dum
   608)       enddo
   609)     endif
   610)   enddo
   611)   
   612)   enddo ! chunk loop
   613)   
   614)   return
   615) 
   616) end subroutine ludcmp_chunk
   617) 
   618) ! ************************************************************************** !
   619) 
   620) subroutine lubksb_chunk(A,N,INDX,B,chunk_size,ithread,num_threads)
   621)   ! 
   622)   ! Solves the set of N linear equations A.X=D. Here A is input, not as a matrix
   623)   ! A but rather as its LU decomposition. INDX is the input as the permutation
   624)   ! vector returned bu ludcmp. B is input as the right-hand side vector B, and
   625)   ! returns with the solution vector X.
   626)   ! 
   627) 
   628)   implicit none
   629) 
   630)   PetscInt :: N
   631)   PetscInt :: chunk_size
   632)   PetscInt :: num_threads
   633)   PetscReal :: A(chunk_size,num_threads,N,N),B(chunk_size,num_threads,N)
   634)   PetscInt :: INDX(chunk_size,num_threads,N)
   635)   PetscInt :: ithread
   636) 
   637)   PetscInt :: i, j, ii, ll
   638)   PetscReal :: sum
   639) 
   640)   PetscInt :: ichunk
   641) 
   642)   do ichunk = 1, chunk_size
   643)   
   644)   ii=0
   645)   do i=1,N
   646)     ll=INDX(ichunk,ithread,i)
   647)     sum=B(ichunk,ithread,ll)
   648)     B(ichunk,ithread,ll)=B(ichunk,ithread,i)
   649)     if (ii.ne.0) then
   650)       do j=ii,i-1
   651)         sum=sum-A(ichunk,ithread,i,j)*B(ichunk,ithread,j)
   652)       enddo
   653)     else if (sum.ne.0) then
   654)       ii=i
   655)     endif
   656)     B(ichunk,ithread,i)=sum
   657)   enddo
   658)   do i=N,1,-1
   659)     sum=B(ichunk,ithread,i)
   660)     if (i.lt.N) then
   661)       do j=i+1,N
   662)         sum=sum-A(ichunk,ithread,i,j)*B(ichunk,ithread,j)
   663)       enddo
   664)     endif
   665)     B(ichunk,ithread,i)=sum/A(ichunk,ithread,i,i)
   666)   enddo
   667)   
   668)   enddo ! chunk loop
   669)   
   670)   return
   671) 
   672) end subroutine lubksb_chunk
   673) 
   674) ! ************************************************************************** !
   675) 
   676) subroutine Interpolate(x_high,x_low,x,y_high,y_low,y)
   677)   ! 
   678)   ! Interpolates values between two reference values
   679)   ! 
   680)   ! Author: Glenn Hammond
   681)   ! Date: 02/09/09
   682)   ! 
   683) 
   684)   implicit none
   685) 
   686)   PetscReal :: x_high, x_low, x
   687)   PetscReal :: y_high, y_low, y
   688)   
   689)   PetscReal :: weight
   690)   PetscReal :: x_diff
   691)   
   692)   x_diff = x_high-x_low
   693)   if (dabs(x_diff) < 1.d-10) then
   694)     y = y_low
   695)   else
   696)     weight = (x-x_low)/x_diff
   697)     y = y_low + weight*(y_high-y_low)
   698)   endif
   699) 
   700) end subroutine Interpolate
   701) 
   702) ! ************************************************************************** !
   703) 
   704) function InterpolateBilinear(x,y,x1,x2,y1,y2,z1,z2,z3,z4)
   705)   ! 
   706)   ! Interpolates values between four reference values in 2D
   707)   ! 
   708)   ! Author: Glenn Hammond
   709)   ! Date: 10/26/11
   710)   ! 
   711) 
   712)   implicit none
   713) 
   714)   PetscReal :: x,y,x1,x2,y1,y2,z1,z2,z3,z4
   715)   PetscReal :: InterpolateBilinear
   716)   
   717)   
   718)   !  x1,y2,z3 ------ x2,y2,z4
   719)   !     |               |
   720)   !     |               |
   721)   !     |   x,y         |
   722)   !     |               |
   723)   !  x1,y1,z1 ------ x2,y1,z2
   724)   
   725)   
   726)   InterpolateBilinear = (z1*(x2-x)*(y2-y)+z2*(x-x1)*(y2-y)+ &
   727)                          z3*(x2-x)*(y-y1)+z4*(x-x1)*(y-y1))/ &
   728)                         ((x2-x1)*(y2-y1))
   729) 
   730) end function InterpolateBilinear
   731) 
   732) ! ************************************************************************** !
   733) 
   734) function DotProduct1(v1,v2)
   735)   ! 
   736)   ! Computes the dot product between two 3d vectors
   737)   ! 
   738)   ! Author: Glenn Hammond
   739)   ! Date: 11/28/07
   740)   ! 
   741) 
   742)   implicit none
   743)   
   744)   PetscReal :: v1(3), v2(3)
   745)   
   746)   PetscReal :: DotProduct1
   747)   
   748)   DotProduct1 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
   749) 
   750) end function DotProduct1
   751) 
   752) ! ************************************************************************** !
   753) 
   754) function DotProduct2(v1,v2x,v2y,v2z)
   755)   ! 
   756)   ! Computes the dot product between two 3d vectors
   757)   ! 
   758)   ! Author: Glenn Hammond
   759)   ! Date: 11/28/07
   760)   ! 
   761) 
   762)   implicit none
   763)   
   764)   PetscReal :: v1(3), v2x, v2y, v2z
   765)   
   766)   PetscReal :: DotProduct2
   767)   
   768)   DotProduct2 = v1(1)*v2x+v1(2)*v2y+v1(3)*v2z
   769) 
   770) end function DotProduct2
   771) 
   772) ! ************************************************************************** !
   773) 
   774) function DotProduct3(v1x,v1y,v1z,v2x,v2y,v2z)
   775)   ! 
   776)   ! Computes the dot product between components of two 3d
   777)   ! vectors
   778)   ! 
   779)   ! Author: Glenn Hammond
   780)   ! Date: 11/28/07
   781)   ! 
   782) 
   783)   implicit none
   784)   
   785)   PetscReal :: v1x, v1y, v1z, v2x, v2y, v2z
   786)   
   787)   PetscReal :: DotProduct3
   788)   
   789)   DotProduct3 = v1x*v2x+v1y*v2y+v1z*v2z
   790) 
   791) end function DotProduct3
   792) 
   793) ! ************************************************************************** !
   794) 
   795) function CrossProduct1(v1,v2)
   796)   ! 
   797)   ! Computes the cross product between two 3d vectors
   798)   ! 
   799)   ! Author: Glenn Hammond
   800)   ! Date: 10/30/09
   801)   ! 
   802) 
   803)   implicit none
   804)   
   805)   PetscReal :: v1(3), v2(3)
   806)   
   807)   PetscReal :: CrossProduct1(3)
   808)   
   809)   CrossProduct1(1) = v1(2)*v2(3)-v1(3)*v2(2)
   810)   CrossProduct1(2) = v1(3)*v2(1)-v1(1)*v2(3)
   811)   CrossProduct1(3) = v1(1)*v2(2)-v1(2)*v2(1)
   812) 
   813) end function CrossProduct1
   814) 
   815) ! ************************************************************************** !
   816) 
   817) function Erf_(x)
   818)   ! 
   819)   ! Computes an approximate to erf(x)
   820)   ! from: http://jin.ece.uiuc.edu/routines/merror.for
   821)   ! 
   822)   ! Author: Glenn Hammond
   823)   ! Date: 05/20/09
   824)   ! 
   825) 
   826)   implicit none
   827)   
   828)   PetscReal :: x
   829)   
   830)   PetscReal :: Erf_
   831) 
   832)   PetscReal, parameter :: EPS = 1.d-15
   833)   PetscReal, parameter :: PI=3.141592653589793d0
   834)   PetscReal :: x2, er, r, co
   835)   PetscInt :: k
   836)   
   837)   x2=x*x
   838)   if (dabs(x) < 3.5d0) then
   839)     er=1.d0
   840)     r=1.d0
   841)     do k = 1, 50
   842)       r=r*x2/(dble(k)+0.5d0)
   843)       er=er+r
   844)       if (dabs(r) < dabs(er)*EPS) exit
   845)     enddo
   846)     co=2.d0/sqrt(PI)*x*exp(-x2)
   847)     Erf_=co*er
   848)   else
   849)     er=1.d0
   850)     r=1.d0
   851)     do k = 1, 12
   852)       r=-r*(dble(k)-0.5d0)/x2
   853)       er=er+r
   854)     enddo
   855)     co=exp(-x2)/(dabs(x)*sqrt(PI))
   856)     Erf_=1.d0-co*er
   857)     if (x < 0.d0) Erf_=-Erf_
   858)   endif
   859) 
   860) end function Erf_
   861) 
   862) ! ************************************************************************** !
   863) 
   864) function InverseErf(p)
   865)   ! 
   866)   ! Erf: Computes an approximate to erf(x)
   867)   ! adapted from
   868)   ! #
   869)   ! # Lower tail quantile for standard normal distribution function.
   870)   ! #
   871)   ! # This function returns an approximation of the inverse cumulative
   872)   ! # standard normal distribution function.  I.e., given P, it returns
   873)   ! # an approximation to the X satisfying P = Pr{Z <= X} where Z is a
   874)   ! # random variable from the standard normal distribution.
   875)   ! #
   876)   ! # The algorithm uses a minimax approximation by rational functions
   877)   ! # and the result has a relative error whose absolute value is less
   878)   ! # than 1.15e-9.
   879)   ! #
   880)   ! # Author:      Peter J. Acklam
   881)   ! # Time-stamp:  2000-07-19 18:26:14
   882)   ! # E-mail:      pjacklam@online.no
   883)   ! # WWW URL:     http://home.online.no/~pjacklam
   884)   ! 
   885)   ! Author: Glenn Hammond
   886)   ! Date: 05/20/09
   887)   ! 
   888) 
   889)   implicit none
   890)   
   891)   PetscReal :: p
   892)   
   893)   PetscReal :: InverseErf
   894)   
   895)  ! Coefficients in rational approximations.
   896)   PetscReal, parameter :: A(6) = (/-3.969683028665376d+1,2.209460984245205d+2, &
   897)                                   -2.759285104469687d+2,1.383577518672690d+2, &
   898)                                   -3.066479806614716d+1,2.506628277459239d+0/)
   899)   PetscReal, parameter :: B(5) = (/-5.447609879822406d+1,1.615858368580409d+2, &
   900)                                   -1.556989798598866d+2,6.680131188771972d+1, &
   901)                                   -1.328068155288572d+1/)
   902)   PetscReal, parameter :: C(6) = (/-7.784894002430293d-3, &
   903)                                   -3.223964580411365d-1, &
   904)                                   -2.400758277161838d+0,-2.549732539343734d+0, &
   905)                                   4.374664141464968d+0,2.938163982698783d+0/)
   906)   PetscReal, parameter :: D(4) = (/7.784695709041462d-03, &
   907)                                   3.224671290700398d-01, &
   908)                                   2.445134137142996d+00,  3.754408661907416d+0/)
   909) 
   910)   ! Define break-points.
   911)   PetscReal, parameter :: PLOW  = 0.02425d0;
   912)   PetscReal, parameter :: PHIGH = 0.97575d0 ! 1 - PLOW;
   913)   PetscReal :: q, r
   914) 
   915)   ! Rational approximation for lower region:
   916)   if (p < PLOW) then
   917)     q = sqrt(-2.d0*log(p))
   918)     InverseErf = (((((C(1)*q+C(2))*q+C(3))*q+C(4))*q+C(5))*q+C(6)) / &
   919)                   ((((D(1)*q+D(2))*q+D(3))*q+D(4))*q+1.d0)
   920)   ! Rational approximation for upper region:
   921)   elseif (PHIGH < p) then
   922)     q = sqrt(-2.d0*log(1.d0-p))
   923)     InverseErf = -(((((C(1)*q+C(2))*q+C(3))*q+C(4))*q+C(5))*q+C(6)) / &
   924)                    ((((D(1)*q+D(2))*q+D(3))*q+D(4))*q+1.d0)
   925)   ! Rational approximation for central region:
   926)   else
   927)     q = p - 0.5d0;
   928)     r = q*q;
   929)     InverseErf = (((((A(1)*r+A(2))*r+A(3))*r+A(4))*r+A(5))*r+A(6))*q / &
   930)                  (((((B(1)*r+B(2))*r+B(3))*r+B(4))*r+B(5))*r+1.d0)
   931)   endif
   932) 
   933) end function InverseErf
   934) 
   935) ! ************************************************************************** !
   936) 
   937) subroutine UtilityReadIntArray(array,array_size,comment,input,option)
   938)   ! 
   939)   ! Reads an array of integers from an input file
   940)   ! 
   941)   ! Author: Glenn Hammond
   942)   ! Date: 11/30/11
   943)   ! 
   944) 
   945)   use Input_Aux_module
   946)   use String_module
   947)   use Option_module
   948)   
   949)   implicit none
   950)   
   951)   type(option_type) :: option
   952)   type(input_type), target :: input
   953)   character(len=MAXSTRINGLENGTH) :: comment
   954)   PetscInt :: array_size
   955)   PetscInt, pointer :: array(:)
   956)   
   957)   PetscInt :: i, num_values, icount
   958)   type(input_type), pointer :: input2
   959)   character(len=MAXSTRINGLENGTH) :: string, string2
   960)   character(len=MAXWORDLENGTH) :: word, word2, word3
   961)   character(len=1) :: backslash
   962)   character(len=MAXSTRINGLENGTH) :: err_string
   963)   PetscBool :: continuation_flag
   964)   PetscInt :: value
   965)   PetscInt, pointer :: temp_array(:)
   966)   PetscInt :: temp_array_size
   967)   PetscErrorCode :: ierr
   968) 
   969)   err_string = trim(comment) // ',UtilityReadIntArray'
   970)   backslash = achar(92)  ! 92 = "\" Some compilers choke on \" thinking it
   971)                           ! is a double quote as in c/c++
   972)   
   973)   temp_array_size = 1000
   974)   if (array_size > 0) then
   975)     temp_array_size = array_size
   976)   endif
   977)   allocate(temp_array(temp_array_size))
   978)   temp_array = 0
   979)   
   980)   input%ierr = 0
   981)   if (len_trim(input%buf) > 0) then
   982)     string2 = trim(input%buf)
   983)     call InputReadWord(input,option,word,PETSC_TRUE)
   984)     call InputErrorMsg(input,option,'file or value','UtilityReadIntArray')
   985)     call StringToLower(word)
   986)     if (StringCompare(word,'file',FOUR_INTEGER)) then
   987)       call InputReadNChars(input,option,string2,MAXSTRINGLENGTH,PETSC_TRUE)
   988)       input%err_buf = 'filename'
   989)       input%err_buf2 = comment
   990)       call InputErrorMsg(input,option)
   991)       input2 => InputCreate(input%fid + 1,string2,option)
   992)     else
   993)       input2 => input
   994)       input%buf = string2
   995)     endif
   996)   else
   997)     input2 => input
   998)   endif
   999)   
  1000)   if (.not. len_trim(input2%buf) > 1) then
  1001)     call InputReadPflotranString(input2,option)
  1002)     call InputReadStringErrorMsg(input2,option,comment)
  1003)   endif
  1004)   
  1005)   icount = 0
  1006)   do
  1007) 
  1008)     continuation_flag = PETSC_FALSE
  1009)     if (index(input2%buf,backslash) > 0) &
  1010)       continuation_flag = PETSC_TRUE
  1011) 
  1012)     do 
  1013)       call InputReadWord(input2,option,word,PETSC_TRUE)
  1014)       if (InputError(input2) .or. &
  1015)           StringCompare(word,backslash,ONE_INTEGER)) exit
  1016)       i = index(word,'*')
  1017)       if (i == 0) i = index(word,'@')
  1018)       if (i /= 0) then
  1019)         word2 = word(1:i-1)
  1020)         word3 = word(i+1:len_trim(word))
  1021)         string2 = word2
  1022)         call InputReadInt(string2,option,num_values,input2%ierr)
  1023)         call InputErrorMsg(input2,option,'# values',err_string)
  1024)         string2 = word3
  1025)         call InputReadInt(string2,option,value,input2%ierr)
  1026)         call InputErrorMsg(input2,option,'value',err_string)
  1027)         do while (icount+num_values > temp_array_size)
  1028)           ! careful.  reallocateRealArray double temp_array_size every time.
  1029)           call reallocateIntArray(temp_array,temp_array_size) 
  1030)         enddo
  1031)         do i=1, num_values
  1032)           icount = icount + 1
  1033)           temp_array(icount) = value
  1034)         enddo
  1035)       else
  1036)         string2 = word
  1037)         call InputReadInt(string2,option,value,input2%ierr)
  1038)         call InputErrorMsg(input2,option,'value',err_string)
  1039)         icount = icount + 1
  1040)         if (icount > temp_array_size) then
  1041)           ! careful.  reallocateRealArray double temp_array_size every time.
  1042)           call reallocateIntArray(temp_array,temp_array_size) 
  1043)         endif
  1044)         temp_array(icount) = value
  1045)       endif
  1046)     enddo
  1047) 
  1048)     if (continuation_flag) then
  1049)       call InputReadPflotranString(input2,option)
  1050)       call InputReadStringErrorMsg(input2,option,comment)
  1051)     else
  1052)       if (array_size > 0) then
  1053)         if (icount == 1) then
  1054)           temp_array = temp_array(icount)
  1055)         else if (icount > array_size .or. icount < array_size) then
  1056)           write(word,*) icount
  1057)           write(word2,*) array_size
  1058)           if (len_trim(comment) > 0) then
  1059)             option%io_buffer = 'Incorrect number of values read in &
  1060)               &UtilityReadIntArray() for ' // trim(comment) // '.'
  1061)           else
  1062)             option%io_buffer = 'Incorrect number of values read in &
  1063)               &UtilityReadIntArray().'
  1064)           endif
  1065)           option%io_buffer = trim(option%io_buffer) // &
  1066)             '  Expected ' // trim(adjustl(word2)) // &
  1067)             ' but read ' // trim(adjustl(word)) // '.'
  1068)           call printErrMsg(option)
  1069)         endif
  1070)         exit
  1071)       else if (icount == 0) then
  1072)         if (len_trim(comment) > 0) then
  1073)           option%io_buffer = 'No values read in UtilityReadIntArray() &
  1074)             &for ' // trim(comment) // '.'
  1075)         else
  1076)           option%io_buffer = 'No values read in UtilityReadIntArray().'
  1077)         endif
  1078)         call printErrMsg(option)
  1079)       else
  1080)         exit
  1081)       endif
  1082)     endif
  1083)   enddo
  1084)   
  1085)   if (array_size > 0) icount = array_size
  1086)   
  1087)   if (.not.associated(input2,input)) call InputDestroy(input2)
  1088)   nullify(input2)
  1089)   
  1090)   if (associated(array)) deallocate(array)
  1091)   allocate(array(icount))
  1092)   array(1:icount) = temp_array(1:icount)
  1093)   deallocate(temp_array)
  1094)   nullify(temp_array)
  1095) 
  1096) end subroutine UtilityReadIntArray
  1097) 
  1098) ! ************************************************************************** !
  1099) 
  1100) subroutine UtilityReadRealArray(array,array_size,comment,input,option)
  1101)   ! 
  1102)   ! Reads an array of double precision numbers from the
  1103)   ! input file
  1104)   ! 
  1105)   ! Author: Glenn Hammond
  1106)   ! Date: 05/21/09
  1107)   ! 
  1108) 
  1109)   use Input_Aux_module
  1110)   use String_module
  1111)   use Option_module
  1112)   
  1113)   implicit none
  1114)   
  1115)   type(option_type) :: option
  1116)   type(input_type), target :: input
  1117)   character(len=MAXSTRINGLENGTH) :: comment
  1118)   PetscInt :: array_size
  1119)   PetscReal, pointer :: array(:)
  1120)   
  1121)   PetscInt :: i, num_values, icount
  1122)   type(input_type), pointer :: input2
  1123)   character(len=MAXSTRINGLENGTH) :: string, string2
  1124)   character(len=MAXWORDLENGTH) :: word, word2, word3
  1125)   character(len=1) :: backslash
  1126)   character(len=MAXSTRINGLENGTH) :: err_string
  1127)   PetscBool :: continuation_flag
  1128)   PetscReal :: value
  1129)   PetscReal, pointer :: temp_array(:)
  1130)   PetscInt :: temp_array_size
  1131)   PetscErrorCode :: ierr
  1132) 
  1133)   err_string = trim(comment) // ',UtilityReadRealArray'
  1134)   backslash = achar(92)  ! 92 = "\" Some compilers choke on \" thinking it
  1135)                           ! is a double quote as in c/c++
  1136)   
  1137)   temp_array_size = 1000
  1138)   if (array_size > 0) then
  1139)     temp_array_size = array_size
  1140)   endif
  1141)   allocate(temp_array(temp_array_size))
  1142)   temp_array = 0.d0
  1143)   
  1144)   input%ierr = 0
  1145)   if (len_trim(input%buf) > 0) then
  1146)     string2 = trim(input%buf)
  1147)     call InputReadWord(input,option,word,PETSC_TRUE)
  1148)     call InputErrorMsg(input,option,'file or value','UtilityReadRealArray')
  1149)     call StringToLower(word)
  1150)     if (StringCompare(word,'file',FOUR_INTEGER)) then
  1151)       call InputReadNChars(input,option,string2,MAXSTRINGLENGTH,PETSC_TRUE)
  1152)       input%err_buf = 'filename'
  1153)       input%err_buf2 = comment
  1154)       call InputErrorMsg(input,option)
  1155)       input2 => InputCreate(input%fid + 1,string2,option)
  1156)     else
  1157)       input2 => input
  1158)       input%buf = string2
  1159)     endif
  1160)   else
  1161)     input2 => input
  1162)   endif
  1163)   
  1164)   if (.not. len_trim(input2%buf) > 1) then
  1165)     call InputReadPflotranString(input2,option)
  1166)     call InputReadStringErrorMsg(input2,option,comment)
  1167)   endif
  1168) 
  1169)   icount = 0
  1170)   do
  1171) 
  1172)     continuation_flag = PETSC_FALSE
  1173)     if (index(input2%buf,backslash) > 0) &
  1174)       continuation_flag = PETSC_TRUE
  1175) 
  1176)     do 
  1177)       call InputReadWord(input2,option,word,PETSC_TRUE)
  1178)       if (InputError(input2) .or. &
  1179)           StringCompare(word,backslash,ONE_INTEGER)) exit
  1180)       i = index(word,'*')
  1181)       if (i == 0) i = index(word,'@')
  1182)       if (i /= 0) then
  1183)         word2 = word(1:i-1)
  1184)         word3 = word(i+1:len_trim(word))
  1185)         string2 = word2
  1186)         call InputReadInt(string2,option,num_values,input2%ierr)
  1187)         call InputErrorMsg(input2,option,'# values',err_string)
  1188)         string2 = word3
  1189)         call InputReadDouble(string2,option,value,input2%ierr)
  1190)         call InputErrorMsg(input2,option,'value',err_string)
  1191)         do while (icount+num_values > temp_array_size)
  1192)           ! careful.  reallocateRealArray double temp_array_size every time.
  1193)           call reallocateRealArray(temp_array,temp_array_size) 
  1194)         enddo
  1195)         do i=1, num_values
  1196)           icount = icount + 1
  1197)           temp_array(icount) = value
  1198)         enddo
  1199)       else
  1200)         string2 = word
  1201)         call InputReadDouble(string2,option,value,input2%ierr)
  1202)         call InputErrorMsg(input2,option,'value',err_string)
  1203)         icount = icount + 1
  1204)         if (icount > temp_array_size) then
  1205)           ! careful.  reallocateRealArray double temp_array_size every time.
  1206)           call reallocateRealArray(temp_array,temp_array_size) 
  1207)         endif
  1208)         temp_array(icount) = value
  1209)       endif
  1210)     enddo
  1211) 
  1212)     if (continuation_flag) then
  1213)       call InputReadPflotranString(input2,option)
  1214)       call InputReadStringErrorMsg(input2,option,comment)
  1215)     else
  1216)       if (array_size > 0) then
  1217)         if (icount == 1) then
  1218)           temp_array = temp_array(icount)
  1219)         else if (icount > array_size .or. icount < array_size) then
  1220)           write(word,*) icount
  1221)           write(word2,*) array_size
  1222)           if (len_trim(comment) > 0) then
  1223)             option%io_buffer = 'Incorrect number of values read in &
  1224)               &UtilityReadRealArray() for ' // trim(comment) // '.'
  1225)           else
  1226)             option%io_buffer = 'Incorrect number of values read in &
  1227)               &UtilityReadRealArray().'
  1228)           endif
  1229)           option%io_buffer = trim(option%io_buffer) // &
  1230)             '  Expected ' // trim(adjustl(word2)) // &
  1231)             ' but read ' // trim(adjustl(word)) // '.'
  1232)           call printErrMsg(option)
  1233)         endif
  1234)         exit
  1235)       else if (icount == 0) then
  1236)         if (len_trim(comment) > 0) then
  1237)           option%io_buffer = 'No values read in UtilityReadRealArray() &
  1238)             &for ' // trim(comment) // '.'
  1239)         else
  1240)           option%io_buffer = 'No values read in UtilityReadRealArray().'
  1241)         endif
  1242)         call printErrMsg(option)
  1243)       else
  1244)         exit
  1245)       endif
  1246)     endif
  1247)   enddo
  1248)   
  1249)   if (array_size > 0) icount = array_size
  1250)   
  1251)   if (.not.associated(input2,input)) call InputDestroy(input2)
  1252)   nullify(input2)
  1253)   
  1254)   if (associated(array)) deallocate(array)
  1255)   allocate(array(icount))
  1256)   array(1:icount) = temp_array(1:icount)
  1257)   deallocate(temp_array)
  1258)   nullify(temp_array)
  1259) 
  1260) end subroutine UtilityReadRealArray
  1261) 
  1262) ! ************************************************************************** !
  1263) 
  1264) function SearchOrderedArray(array,array_length,int_value)
  1265)   ! 
  1266)   ! Locates an integer value in an ordered array and
  1267)   ! returned the index
  1268)   ! 
  1269)   ! Author: Glenn Hammond
  1270)   ! Date: 10/21/09
  1271)   ! 
  1272) 
  1273)   implicit none
  1274) 
  1275)   PetscInt :: array_length 
  1276)   PetscInt :: array(array_length)
  1277)   PetscInt :: int_value
  1278) 
  1279)   PetscInt :: SearchOrderedArray
  1280)   PetscInt :: i
  1281)   PetscInt :: array_value
  1282)   PetscInt :: upper_bound, lower_bound
  1283) 
  1284)   SearchOrderedArray = -1
  1285) 
  1286)   upper_bound = array_length
  1287)   lower_bound = 1
  1288) 
  1289)   i = array_length/2
  1290)   if (i == 0) i = 1
  1291) 
  1292)   do 
  1293)     array_value = array(i)
  1294)     if (array_value == int_value) then
  1295)       SearchOrderedArray = i
  1296)       return
  1297)     endif
  1298)     if (array_value > int_value) then
  1299)       upper_bound = i 
  1300)     else
  1301)       lower_bound = i 
  1302)     endif
  1303)     i = lower_bound + (upper_bound-lower_bound) / 2
  1304)     if (i == lower_bound) then
  1305)       if (array(lower_bound) == int_value) SearchOrderedArray = lower_bound
  1306)       if (array(upper_bound) == int_value) SearchOrderedArray = upper_bound
  1307)       return
  1308)     endif
  1309)   enddo
  1310) 
  1311) end function SearchOrderedArray
  1312) 
  1313) ! ************************************************************************** !
  1314) 
  1315) function FileExists(filename)
  1316)   ! 
  1317)   ! Returns PETSC_TRUE if file exists
  1318)   ! 
  1319)   ! Author: Glenn Hammond
  1320)   ! Date: 04/27/11
  1321)   ! 
  1322) 
  1323)   implicit none
  1324)   
  1325)   PetscBool :: FileExists
  1326) 
  1327)   character(len=*) :: filename
  1328)   
  1329)   inquire(file=filename,exist=FileExists)
  1330) 
  1331) end function FileExists
  1332) 
  1333) ! ************************************************************************** !
  1334) 
  1335) function Equal(value1, value2)
  1336)   ! 
  1337)   ! Returns PETSC_TRUE if values are equal
  1338)   ! 
  1339)   ! Author: Glenn Hammond
  1340)   ! Date: 04/27/11
  1341)   ! 
  1342) 
  1343)   implicit none
  1344)   
  1345)   PetscBool :: Equal
  1346) 
  1347)   PetscReal :: value1, value2
  1348) 
  1349)   Equal = PETSC_FALSE
  1350)   if (dabs(value1 - value2) <= 1.d-14 * dabs(value1))  Equal = PETSC_TRUE
  1351)   
  1352) end function Equal
  1353) 
  1354) ! ************************************************************************** !
  1355) 
  1356) function BestFloat(float,upper_bound,lower_bound)
  1357)   ! 
  1358)   ! Returns the best format for a floating point number
  1359)   ! 
  1360)   ! Author: Glenn Hammond
  1361)   ! Date: 11/21/11
  1362)   ! 
  1363) 
  1364)   implicit none
  1365)   
  1366)   PetscReal :: float
  1367)   PetscReal :: upper_bound
  1368)   PetscReal :: lower_bound
  1369) 
  1370)   character(len=MAXWORDLENGTH) :: BestFloat
  1371)   character(len=MAXWORDLENGTH) :: word
  1372)   PetscInt :: i
  1373)   
  1374) 100 format(f12.3)
  1375) 101 format(es12.2)
  1376) 102 format(es12.4)
  1377) 
  1378)   if (dabs(float) <= upper_bound .and. dabs(float) >= lower_bound) then
  1379)     write(word,100) float
  1380)     word = adjustl(word)
  1381)     do i = len_trim(word), 1, -1
  1382)       if (word(i:i) == '0') then
  1383)         word(i:i) = ' '
  1384)       else
  1385)         exit
  1386)       endif
  1387)     enddo
  1388)   else if (dabs(float) < lower_bound) then
  1389)     write(word,101) float
  1390)   else
  1391)     write(word,102) float
  1392)   endif
  1393)   
  1394)   BestFloat = adjustl(word)
  1395)   
  1396) end function BestFloat
  1397) 
  1398) ! ************************************************************************** !
  1399) 
  1400) subroutine QuadraticPolynomialSetup(value_1,value_2,coefficients, &
  1401)                                     derivative_at_1)
  1402)   ! 
  1403)   ! Sets up a quadratic polynomial for smoothing discontinuous functions
  1404)   ! 
  1405)   ! Author: Glenn Hammond
  1406)   ! Date: 04/25/14
  1407)   ! 
  1408) 
  1409)   implicit none
  1410) 
  1411)   PetscReal :: value_1
  1412)   PetscReal :: value_2
  1413)   PetscReal :: coefficients(3)
  1414)   PetscBool :: derivative_at_1
  1415)   
  1416)   PetscReal :: A(3,3)
  1417)   PetscInt :: indx(3)
  1418)   PetscInt :: d
  1419) 
  1420)   A(1,1) = 1.d0
  1421)   A(2,1) = 1.d0
  1422)   A(3,1) = 0.d0
  1423)   
  1424)   A(1,2) = value_1
  1425)   A(2,2) = value_2
  1426)   A(3,2) = 1.d0
  1427)   
  1428)   A(1,3) = value_1**2.d0
  1429)   A(2,3) = value_2**2.d0
  1430)   if (derivative_at_1) then
  1431)     A(3,3) = 2.d0*value_1
  1432)   else
  1433)     A(3,3) = 2.d0*value_2
  1434)   endif
  1435)   
  1436)   ! coefficients(1): value at 1
  1437)   ! coefficients(2): value at 2
  1438)   ! coefficients(3): derivative at 1 or 2
  1439)   
  1440)   call ludcmp(A,THREE_INTEGER,indx,d)
  1441)   call lubksb(A,THREE_INTEGER,indx,coefficients)
  1442) 
  1443) end subroutine QuadraticPolynomialSetup
  1444) 
  1445) ! ************************************************************************** !
  1446) 
  1447) subroutine QuadraticPolynomialEvaluate(coefficients,x,f,df_dx)
  1448)   ! 
  1449)   ! Evaluates value in quadratic polynomial
  1450)   ! 
  1451)   ! Author: Glenn Hammond
  1452)   ! Date: 03/12/12
  1453)   ! 
  1454) 
  1455)   implicit none
  1456) 
  1457)   PetscReal :: coefficients(3)
  1458)   PetscReal :: x
  1459)   PetscReal :: f
  1460)   PetscReal :: df_dx
  1461) 
  1462)   f = coefficients(1) + &
  1463)       coefficients(2)*x + &
  1464)       coefficients(3)*x*x
  1465)   
  1466)   df_dx = coefficients(2) + &
  1467)           coefficients(3)*2.d0*x
  1468)   
  1469) end subroutine QuadraticPolynomialEvaluate
  1470) 
  1471) ! ************************************************************************** !
  1472) 
  1473) subroutine CubicPolynomialSetup(value_1,value_2,coefficients)
  1474)   ! 
  1475)   ! Sets up a cubic polynomial for smoothing discontinuous functions
  1476)   ! 
  1477)   ! Author: Glenn Hammond
  1478)   ! Date: 03/12/12
  1479) 
  1480)   implicit none
  1481) 
  1482)   PetscReal :: value_1
  1483)   PetscReal :: value_2
  1484)   PetscReal :: coefficients(4)
  1485)   
  1486)   PetscReal :: A(4,4)
  1487)   PetscInt :: indx(4)
  1488)   PetscInt :: d
  1489) 
  1490)   A(1,1) = 1.d0
  1491)   A(2,1) = 1.d0
  1492)   A(3,1) = 0.d0
  1493)   A(4,1) = 0.d0
  1494)   
  1495)   A(1,2) = value_1
  1496)   A(2,2) = value_2
  1497)   A(3,2) = 1.d0
  1498)   A(4,2) = 1.d0
  1499)   
  1500)   A(1,3) = value_1**2.d0
  1501)   A(2,3) = value_2**2.d0
  1502)   A(3,3) = 2.d0*value_1
  1503)   A(4,3) = 2.d0*value_2
  1504)   
  1505)   A(1,4) = value_1**3.d0
  1506)   A(2,4) = value_2**3.d0
  1507)   A(3,4) = 3.d0*value_1**2.d0
  1508)   A(4,4) = 3.d0*value_2**2.d0
  1509)   
  1510)   ! coefficients(1): value at 1
  1511)   ! coefficients(2): value at 2
  1512)   ! coefficients(3): derivative at 1
  1513)   ! coefficients(4): derivative at 2
  1514)   
  1515)   call ludcmp(A,FOUR_INTEGER,indx,d)
  1516)   call lubksb(A,FOUR_INTEGER,indx,coefficients)
  1517) 
  1518) end subroutine CubicPolynomialSetup
  1519) 
  1520) ! ************************************************************************** !
  1521) 
  1522) subroutine CubicPolynomialEvaluate(coefficients,x,f,df_dx)
  1523)   ! 
  1524)   ! Evaluates value in cubic polynomial
  1525)   ! 
  1526)   ! Author: Glenn Hammond
  1527)   ! Date: 03/12/12
  1528)   ! 
  1529) 
  1530)   implicit none
  1531) 
  1532)   PetscReal :: coefficients(4)
  1533)   PetscReal :: x
  1534)   PetscReal :: f
  1535)   PetscReal :: df_dx
  1536) 
  1537)   PetscReal :: x_squared
  1538)   
  1539)   x_squared = x*x
  1540)   
  1541)   f = coefficients(1) + &
  1542)       coefficients(2)*x + &
  1543)       coefficients(3)*x_squared + &
  1544)       coefficients(4)*x_squared*x
  1545)   
  1546)   df_dx = coefficients(2) + &
  1547)           coefficients(3)*2.d0*x + &
  1548)           coefficients(4)*3.d0*x_squared
  1549)   
  1550) end subroutine CubicPolynomialEvaluate
  1551) 
  1552) ! ************************************************************************** !
  1553) 
  1554) subroutine DeallocateArray1DInteger(array)
  1555)   ! 
  1556)   ! Deallocates a 1D integer array
  1557)   ! 
  1558)   ! Author: Glenn Hammond
  1559)   ! Date: 03/13/12
  1560)   ! 
  1561) 
  1562)   implicit none
  1563)   
  1564)   PetscInt, pointer :: array(:)
  1565)   
  1566)   if (associated(array)) deallocate(array)
  1567)   nullify(array)
  1568) 
  1569) end subroutine DeallocateArray1DInteger
  1570) 
  1571) ! ************************************************************************** !
  1572) 
  1573) subroutine DeallocateArray2DInteger(array)
  1574)   ! 
  1575)   ! Deallocates a 2D integer array
  1576)   ! 
  1577)   ! Author: Glenn Hammond
  1578)   ! Date: 03/13/12
  1579)   ! 
  1580) 
  1581)   implicit none
  1582)   
  1583)   PetscInt, pointer :: array(:,:)
  1584)   
  1585)   if (associated(array)) deallocate(array)
  1586)   nullify(array)
  1587) 
  1588) end subroutine DeallocateArray2DInteger
  1589) 
  1590) ! ************************************************************************** !
  1591) 
  1592) subroutine DeallocateArray3DInteger(array)
  1593)   ! 
  1594)   ! Deallocates a 3D integer array
  1595)   ! 
  1596)   ! Author: Glenn Hammond
  1597)   ! Date: 03/13/12
  1598)   ! 
  1599) 
  1600)   implicit none
  1601)   
  1602)   PetscInt, pointer :: array(:,:,:)
  1603)   
  1604)   if (associated(array)) deallocate(array)
  1605)   nullify(array)
  1606) 
  1607) end subroutine DeallocateArray3DInteger
  1608) 
  1609) ! ************************************************************************** !
  1610) 
  1611) subroutine DeallocateArray1DReal(array)
  1612)   ! 
  1613)   ! Deallocates a 1D real array
  1614)   ! 
  1615)   ! Author: Glenn Hammond
  1616)   ! Date: 03/13/12
  1617)   ! 
  1618) 
  1619)   implicit none
  1620)   
  1621)   PetscReal, pointer :: array(:)
  1622)   
  1623)   if (associated(array)) deallocate(array)
  1624)   nullify(array)
  1625) 
  1626) end subroutine DeallocateArray1DReal
  1627) 
  1628) ! ************************************************************************** !
  1629) 
  1630) subroutine DeallocateArray2DReal(array)
  1631)   ! 
  1632)   ! Deallocates a 2D real array
  1633)   ! 
  1634)   ! Author: Glenn Hammond
  1635)   ! Date: 03/13/12
  1636)   ! 
  1637) 
  1638)   implicit none
  1639)   
  1640)   PetscReal, pointer :: array(:,:)
  1641)   
  1642)   if (associated(array)) deallocate(array)
  1643)   nullify(array)
  1644) 
  1645) end subroutine DeallocateArray2DReal
  1646) 
  1647) ! ************************************************************************** !
  1648) 
  1649) subroutine DeallocateArray3DReal(array)
  1650)   ! 
  1651)   ! Deallocates a 3D real array
  1652)   ! 
  1653)   ! Author: Glenn Hammond
  1654)   ! Date: 03/13/12
  1655)   ! 
  1656) 
  1657)   implicit none
  1658)   
  1659)   PetscReal, pointer :: array(:,:,:)
  1660)   
  1661)   if (associated(array)) deallocate(array)
  1662)   nullify(array)
  1663) 
  1664) end subroutine DeallocateArray3DReal
  1665) 
  1666) ! ************************************************************************** !
  1667) 
  1668) subroutine DeallocateArray1DLogical(array)
  1669)   ! 
  1670)   ! Deallocates a 1D logical array
  1671)   ! 
  1672)   ! Author: Glenn Hammond
  1673)   ! Date: 03/13/12
  1674)   ! 
  1675) 
  1676)   implicit none
  1677)   
  1678)   PetscBool, pointer :: array(:)
  1679)   
  1680)   if (associated(array)) deallocate(array)
  1681)   nullify(array)
  1682) 
  1683) end subroutine DeallocateArray1DLogical
  1684) 
  1685) ! ************************************************************************** !
  1686) 
  1687) subroutine DeallocateArray2DLogical(array)
  1688)   ! 
  1689)   ! Deallocates a 2D logical array
  1690)   ! 
  1691)   ! Author: Glenn Hammond
  1692)   ! Date: 03/13/12
  1693)   ! 
  1694) 
  1695)   implicit none
  1696)   
  1697)   PetscBool, pointer :: array(:,:)
  1698)   
  1699)   if (associated(array)) deallocate(array)
  1700)   nullify(array)
  1701) 
  1702) end subroutine DeallocateArray2DLogical
  1703) 
  1704) ! ************************************************************************** !
  1705) 
  1706) subroutine DeallocateArray3DLogical(array)
  1707)   ! 
  1708)   ! Deallocates a 3D logical array
  1709)   ! 
  1710)   ! Author: Glenn Hammond
  1711)   ! Date: 03/13/12
  1712)   ! 
  1713) 
  1714)   implicit none
  1715)   
  1716)   PetscBool, pointer :: array(:,:,:)
  1717)   
  1718)   if (associated(array)) deallocate(array)
  1719)   nullify(array)
  1720) 
  1721) end subroutine DeallocateArray3DLogical
  1722) 
  1723) ! ************************************************************************** !
  1724) 
  1725) subroutine DeallocateArray1DString(array)
  1726)   ! 
  1727)   ! Deallocates a 1D array of character strings
  1728)   ! 
  1729)   ! Author: Glenn Hammond
  1730)   ! Date: 03/13/12
  1731)   ! 
  1732) 
  1733)   implicit none
  1734)   
  1735)   character(len=MAXWORDLENGTH), pointer :: array(:)
  1736)   
  1737)   if (associated(array)) deallocate(array)
  1738)   nullify(array)
  1739) 
  1740) end subroutine DeallocateArray1DString
  1741) 
  1742) ! ************************************************************************** !
  1743) 
  1744) subroutine DeallocateArray2DString(array)
  1745)   ! 
  1746)   ! Deallocates a 2D array of character strings
  1747)   ! 
  1748)   ! Author: Glenn Hammond
  1749)   ! Date: 10/30/12
  1750)   ! 
  1751) 
  1752)   implicit none
  1753)   
  1754)   character(len=MAXWORDLENGTH), pointer :: array(:,:)
  1755)   
  1756)   if (associated(array)) deallocate(array)
  1757)   nullify(array)
  1758) 
  1759) end subroutine DeallocateArray2DString
  1760) 
  1761) ! ************************************************************************** !
  1762) 
  1763) subroutine ConvertMatrixToVector(A,vecA)
  1764)   ! 
  1765)   ! Converts a given matrix A to a vec
  1766)   ! This vec is different from PETSc Vec
  1767)   ! A = [a1 a2 a3 .... am], where ai, i = 1, m are the columns
  1768)   ! then vec(A) = [a1
  1769)   ! a2
  1770)   ! .
  1771)   ! .
  1772)   ! .
  1773)   ! am]
  1774)   ! 
  1775)   ! Author: Satish Karra, LANL
  1776)   ! Date: 6/19/2013
  1777)   ! 
  1778) 
  1779)   PetscReal :: A(:,:)
  1780)   PetscReal, allocatable :: vecA(:,:)
  1781)   PetscInt :: m, n, i, j
  1782)   
  1783)   m = size(A,1)
  1784)   n = size(A,2)
  1785)   
  1786)   allocate(vecA(m*n,ONE_INTEGER))
  1787)   
  1788)   vecA = reshape(A,(/m*n,ONE_INTEGER/))
  1789) 
  1790) end subroutine ConvertMatrixToVector
  1791) 
  1792) ! ************************************************************************** !
  1793) 
  1794) subroutine Kron(A,B,K)
  1795)   ! 
  1796)   ! Returns the Kronecker product of two matrices A, B
  1797)   ! Reference: The ubiquitous Kronecker product, by Charles F.Van Loan
  1798)   ! for basics of Kronecker product
  1799)   ! Also see wikipedia page: http://en.wikipedia.org/wiki/Kronecker_product
  1800)   ! 
  1801)   ! Author: Satish Karra, LANL
  1802)   ! Date: 6/19/2013
  1803)   ! 
  1804) 
  1805)   PetscReal :: A(:,:),B(:,:)
  1806)   PetscReal, allocatable :: K(:,:)
  1807)   PetscInt :: mA,nA,mB,nB
  1808)   PetscInt :: iA,jA,iB,jB,iK,jK
  1809)   
  1810)   mA = size(A,1)
  1811)   nA = size(A,2)
  1812)   mB = size(B,1)
  1813)   nB = size(B,2)
  1814)   
  1815)   allocate(K(mA*mB,nA*nB))
  1816)   
  1817)   do iB = 1, mB
  1818)     do jB = 1, nB
  1819)       do iA = 1, mA
  1820)         do jA = 1, nA
  1821)           iK = iB + (iA-1)*mB
  1822)           jK = jB + (jA-1)*nB
  1823)           K(iK,jK) = A(iA,jA)*B(iB,jB)
  1824)         enddo
  1825)       enddo
  1826)     enddo
  1827)   enddo
  1828)   
  1829) end subroutine Kron
  1830) 
  1831) ! ************************************************************************** !
  1832) 
  1833) subroutine Transposer(m,n,T)
  1834)   ! 
  1835)   ! Transposer Converts vec of a matrix to vec of its transpose
  1836)   ! 
  1837)   ! Author: Satish Karra, LANL
  1838)   ! Date: 6/19/2013
  1839)   ! 
  1840) 
  1841)   PetscReal, allocatable :: T(:,:)
  1842)   PetscInt :: m,n
  1843)   PetscInt :: i,j
  1844)   PetscReal :: A(m,n)
  1845)   PetscReal, allocatable :: vecA(:,:)
  1846)   
  1847)   allocate(T(m*n,m*n))
  1848)   T = 0.d0
  1849)   
  1850)   do i = 1,m
  1851)     do j = 1,n
  1852)       A = 0.d0
  1853)       A(i,j) = 1.d0
  1854)       call ConvertMatrixToVector(transpose(A),vecA)
  1855)       T(:,i+m*(j-1)) = vecA(:,1)
  1856)       deallocate(vecA)
  1857)     enddo
  1858)   enddo
  1859)   
  1860) end subroutine Transposer
  1861) 
  1862) ! ************************************************************************** !
  1863) 
  1864) subroutine Determinant(A,detA)
  1865)   ! 
  1866)   ! Determinant of a 3x3 matrix
  1867)   ! 
  1868)   ! Author: Satish Karra, LANL
  1869)   ! Date: 6/24/2013
  1870)   ! 
  1871) 
  1872)   PetscReal :: A(3,3)
  1873)   PetscReal :: detA  
  1874)  
  1875)   detA = A(1,1)*(A(2,2)*A(3,3) - A(3,2)*A(2,3)) &
  1876)        + A(1,2)*(A(3,1)*A(2,3) - A(2,1)*A(3,3))  &
  1877)        + A(1,3)*(A(2,1)*A(3,2) - A(3,1)*A(2,2))
  1878)   
  1879) 
  1880) end subroutine Determinant
  1881) 
  1882) ! ************************************************************************** !
  1883) subroutine InterfaceApproxWithDeriv(v_up, v_dn, dv_up, dv_dn, dv_up2dn, &
  1884)                                     approx_type, v_interf, &
  1885)                                     dv_interf_dv_up, dv_interf_dv_dn)
  1886)   ! 
  1887)   ! Approximates interface value and it's derivative from values specified
  1888)   ! up and down of a face based on the approximation type
  1889)   ! 
  1890)   ! Author: Gautam Bisht, LBL
  1891)   ! Date: 05/05/2014
  1892)   ! 
  1893) 
  1894)   implicit none
  1895)   
  1896)   PetscReal, intent(in) :: v_up, v_dn
  1897)   PetscReal, intent(in) :: dv_up, dv_dn
  1898)   PetscReal, intent(in) :: dv_up2dn
  1899)   PetscInt, intent(in) :: approx_type
  1900)   PetscReal, intent(out) :: v_interf, dv_interf_dv_up, dv_interf_dv_dn
  1901) 
  1902)   PetscReal :: denom
  1903)   PetscReal :: eps = 1.d-15
  1904) 
  1905) 
  1906)   if (dv_up2dn > 0.d0) then
  1907)     v_interf = v_up
  1908)     dv_interf_dv_up = dv_up
  1909)     dv_interf_dv_dn = 0.d0
  1910)   else
  1911)     v_interf = v_dn
  1912)     dv_interf_dv_up = 0.d0
  1913)     dv_interf_dv_up = dv_dn
  1914)   endif
  1915) 
  1916)   select case (approx_type)
  1917) 
  1918)     case (UPWIND)
  1919)       if (dv_up2dn > 0.d0) then
  1920)         v_interf = v_up
  1921)         dv_interf_dv_up = dv_up
  1922)         dv_interf_dv_dn = 0.d0
  1923)       else
  1924)         v_interf = v_dn
  1925)         dv_interf_dv_up = 0.d0
  1926)         dv_interf_dv_dn = dv_dn
  1927)       endif
  1928) 
  1929)     case (HARMONIC)
  1930)       if (v_up < eps .or. v_dn < eps) then
  1931)         v_interf = 0.d0
  1932)         dv_interf_dv_up = 0.d0
  1933)         dv_interf_dv_dn = 0.d0
  1934)       else
  1935)         denom = (v_up + v_dn)
  1936)         v_interf = 2.d0*v_up*v_dn/denom
  1937)         dv_interf_dv_up = 2.d0*(denom*dv_up*v_dn - v_up*v_dn*dv_up)/(denom**2.d0)
  1938)         dv_interf_dv_dn = 2.d0*(denom*v_up*dv_dn - v_up*v_dn*dv_dn)/(denom**2.d0)
  1939)       endif
  1940) 
  1941)   end select
  1942) 
  1943) end subroutine InterfaceApproxWithDeriv
  1944) 
  1945) ! ************************************************************************** !
  1946) 
  1947) subroutine InterfaceApproxWithoutDeriv(v_up, v_dn, dv_up2dn, &
  1948)                                        approx_type, v_interf)
  1949)   ! 
  1950)   ! Approximates interface value from values specified
  1951)   ! up and down of a face based on the approximation type
  1952)   ! 
  1953)   ! Author: Gautam Bisht, LBL
  1954)   ! Date: 05/05/2014
  1955)   ! 
  1956) 
  1957)   implicit none
  1958)   
  1959)   PetscReal, intent(in) :: v_up, v_dn
  1960)   PetscReal, intent(in) :: dv_up2dn
  1961)   PetscInt, intent(in) :: approx_type
  1962)   PetscReal, intent(out) :: v_interf
  1963) 
  1964)   PetscReal :: dummy_in
  1965)   PetscReal :: dummy_out
  1966) 
  1967)   dummy_in = 1.d0
  1968) 
  1969)   call InterfaceApproxWithDeriv(v_up, v_dn, dummy_in, dummy_in, dv_up2dn, &
  1970)                                 approx_type, v_interf, dummy_out, dummy_out)
  1971) 
  1972) end subroutine InterfaceApproxWithoutDeriv
  1973) 
  1974) ! ************************************************************************** !
  1975) 
  1976) subroutine PrintProgressBarInt(max,increment,current)
  1977)   ! 
  1978)   ! Prints a piece of a progress bar to the screen based on the maximum
  1979)   ! value, the increment of progress (must be given in percent), and the
  1980)   ! current value.
  1981)   ! 
  1982)   ! Author: Jenn Frederick, SNL
  1983)   ! Date: 03/16/2016
  1984)   ! 
  1985) 
  1986)   implicit none
  1987)   
  1988)   PetscInt :: max
  1989)   PetscInt :: increment
  1990)   PetscInt :: current
  1991) 
  1992)   PetscInt :: g, j, chunk
  1993)   character(len=MAXWORDLENGTH) :: percent_num
  1994) 
  1995)   if (max < increment) then
  1996)     max = max*(increment/max)
  1997)     current = current*(increment/max)
  1998)   endif
  1999) 
  2000)   chunk = floor(max*(increment/100.0))
  2001) 
  2002)   if (mod(current,chunk) == 0) then
  2003)     j = current/chunk
  2004)     g = 0
  2005)     do while(g < (100))
  2006)       g = g + increment
  2007)       if (g/increment == j) then
  2008)         write(percent_num,*) g
  2009)         write(*,'(a4)',advance='no') trim(adjustl(percent_num)) // '%-'
  2010)         if (g == 100) write(*,*) '  Done.'
  2011)       endif
  2012)     enddo   
  2013)   endif
  2014) 
  2015) end subroutine PrintProgressBarInt
  2016) 
  2017) end module Utility_module

generated by
Intel(R) C++/Fortran Compiler code-coverage tool
Web-Page Owner: Nobody