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