femwind/fortran/module_utils.f90

   1 module module_utils
   2
   3 contains
   4
   5 ! function to go beyond domain boundary if tile is next to it
   6 integer function snode(t,d,i)
   7 implicit none
   8 integer, intent(in)::t,d,i
   9 if(t.ne.d)then
  10     snode=t
  11 else
  12     snode=t+i
  13 endif
  14 end function snode
  15
  16 subroutine pause
  17 print *,'press enter to continue'
  18 read(*,*)
  19 end subroutine pause
  20
  21 subroutine message(s)
  22 character(len=*)::s
  23 print *,trim(s)
  24 end subroutine message
  25
  26
  27 subroutine crash(msg)
  28 ! terminate with error
  29 character(len=*),intent(in)::msg
  30 write(*,*)'FATAL:',trim(msg)
  31 stop
  32 end subroutine crash
  33
  34 subroutine read_array(a,name)
  35
  36 !*** purpose read array from text file
  37 implicit none
  38
  39 !*** arguments
  40 real, pointer, intent(out):: a(:,:,:)  ! the array pointer; remember to deallocate when done with it
  41 character(len=*),intent(in)::name! file name root, .txt will be added
  42
  43 !*** internal
  44 integer:: n(3),iu=8,j
  45
  46 !*** executable
  47 open(iu,file=trim(name)//'.txt',form='formatted',status='old')
  48 read(iu,*)j
  49 if(j.ne.456)call crash('read_array: wrong magic number')
  50 read(iu,*)j
  51 if(j.ne.3)call crash('read_array: must have 3 dimensions')
  52 read(iu,*)n
  53 1 format('reading matrix size ',3i5,' from file ',a)
  54 write(*,1)n,trim(name)//'.txt'
  55 allocate(a(n(1),n(2),n(3)))
  56 read(iu,*)a
  57 close(iu)
  58 end subroutine read_array
  59
  60
  61 subroutine write_scalar(a,name)
  62 real, intent(in):: a
  63 character(len=*),intent(in)::name! file name root, .txt will be added
  64 call write_array_nd((/a/),(/1/),name)
  65 end subroutine write_scalar
  66
  67
  68
  69 subroutine write_array(a,name)
  70 !*** purpose write array to text file
  71 !*** arguments
  72 real, intent(in):: a(:,:,:)
  73 character(len=*),intent(in)::name! file name root, .txt will be added
  74
  75 !*** internal
  76 integer:: n(3),iu=8,i1,i2,i3
  77
  78 !*** executable
  79 iu=8
  80 open(iu,file=trim(name)//'.txt',form='formatted',status='unknown')
  81 write(iu,*)456
  82 write(iu,*)3
  83 n=shape(a)
  84 write(iu,*)n(1)
  85 write(iu,*)n(2)
  86 write(iu,*)n(3)
  87 1 format('writing matrix size ',3i5,' to file ',a)
  88 write(*,1)n,trim(name)//'.txt.'
  89 do i3=1,n(3)
  90 do i2=1,n(2)
  91 do i1=1,n(1)
  92 write(iu,*)a(i1,i2,i3)
  93 enddo
  94 enddo
  95 enddo
  96 close(iu)
  97 end subroutine write_array
  98
  99 subroutine read_array_nd(a,s,name)
 100 !*** purpose read nd array from text file
 101 !   usage
 102 !   integer :: s(k)  ! k is constant
 103 !   real, pointer :: a(:)
 104 !   call read_array_nd(a,s,'file')
 105 !   target_array = reshape(a,s)
 106 !
 107 implicit none
 108
 109 !*** arguments
 110 integer, intent(out):: s(:)  ! the array shape pointer
 111 real, pointer, intent(out):: a(:)  ! the array data pointer
 112 character(len=*),intent(in)::name! file name root, .txt will be added
 113
 114 !*** internal
 115 integer:: iu=8,n,j,sn(1)
 116
 117 !*** executable
 118 open(iu,file=trim(name)//'.txt',form='formatted',status='old')
 119 read(iu,*)j
 120 if(j.ne.456)call crash('read_array: wrong magic number')
 121 read(iu,*)j
 122 sn = shape(s)
 123 if(j.ne.sn(1))call crash('read_array: wrong number of dimensions')
 124 if(j.lt.1.or.j.gt.7)call crash('read_array: must have 1 to 7 dimensions')
 125
 126 read(iu,*)s
 127 1 format('file ',a,' reading matrix size ',7i8)
 128 write(*,1)trim(name)//'.txt.',s
 129 allocate(a(product(s)))
 130 read(iu,*)a
 131 close(iu)
 132 end subroutine read_array_nd
 133
 134 subroutine write_array_nd(a,s,name)
 135 !*** purpose write array to text file
 136 !*** usage
 137 !   s = shape(a)
 138 !   call write_array_nd(reshape(a,(/product(s)\)),'file')
 139
 140 implicit none
 141 !*** arguments
 142 integer, intent(in):: s(:)
 143 real, intent(in):: a(:)
 144 character(len=*),intent(in)::name! file name root, .txt will be added
 145
 146 !*** internal
 147 integer::n(1),m(1),i,iu
 148 !*** executable
 149 iu=8
 150 1 format('writing ',a,' matrix size ',7i5)
 151 write(*,1)trim(name)//'.txt',s
 152 n = shape(s)
 153 m = shape(a)
 154 if (product(s).ne.m(1))call crash('write_array_nd: wrong size of a')
 155 open(iu,file=trim(name)//'.txt',form='formatted',status='unknown')
 156 write(iu,*)456
 157 write(iu,*)n
 158 do i=1,n(1)
 159     write(iu,*)s(i)
 160 enddo
 161 do i=1,m(1)
 162     write(iu,*)a(i)
 163 enddo
 164 close(iu)
 165 end subroutine write_array_nd
 166
 167
 168 subroutine set_indices(n,nwrap,                   &
 169     ifds, ifde, kfds,kfde, jfds,jfde,             & ! fire grid dimensions
 170     ifms, ifme, kfms,kfme, jfms,jfme,             &
 171     ifts, ifte, kfts,kfte, jfts,jfte)
 172 implicit none
 173
 174 integer, intent(in)::n(3),nwrap
 175 integer, intent(out)::                            &
 176     ifds, ifde, kfds,kfde, jfds,jfde,             & ! fire grid dimensions
 177     ifms, ifme, kfms,kfme, jfms,jfme,             &
 178     ifts, ifte, kfts,kfte, jfts,jfte
 179
 180 ! tile dimensions from matrix size
 181 ifts=1
 182 ifte=n(1)
 183 kfts=1
 184 kfte=n(2)
 185 jfts=1
 186 jfte=n(3)
 187 ! domain = tile
 188 ifds=ifts
 189 ifde=ifte
 190 kfds=kfts
 191 kfde=kfte
 192 jfds=jfts
 193 jfde=jfte
 194 ifms=ifts - nwrap
 195 ifme=ifte + nwrap
 196 kfms=kfts
 197 kfme=kfte
 198 jfms=jfts - nwrap
 199 jfme=jfte + nwrap
 200
 201 end subroutine set_indices
 202
 203 integer function get_chsum(a)
 204 ! xor check sum of 3D real array
 205 implicit none
 206 !*** arguments
 207 real, intent(in)::a(:,:,:)
 208 !*** local
 209 integer::lb(3),ub(3),i,j,k,lsum,iel
 210 real::rel
 211 equivalence(rel,iel)
 212 !*** executable
 213 lb = lbound(a)
 214 ub = ubound(a)
 215 lsum=0
 216 do j=lb(3),ub(3)
 217   do k=lb(2),ub(2)
 218     do i=lb(1),ub(1)
 219       rel=a(i,k,j)
 220       lsum=ieor(lsum,iel)
 221       !print *,i,k,j,rel,iel,lsum
 222     enddo
 223   enddo
 224 enddo
 225
 226 get_chsum = lsum
 227
 228 end function get_chsum
 229
 230 end module module_utils