|
XBeach
|
00001 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00002 !!!!!!!!!!!!!!!!!!!!!!! MODULE OUTPUT !!!!!!!!!!!!!!!!!!!!!!!!!!!! 00003 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00004 ! Note: all code here has been made dead by the following #if 0 00005 ! the file is preserved for reference 00006 #if 0 00007 ! 00008 ! if defined OUTSINGLE, varoutput will output all reals in single precision 00009 ! otherwise: double precision 00010 ! 00011 #define OUTSINGLE 00012 #ifdef OUTSINGLE 00013 #define CONVREAL sngl 00014 #else 00015 #define CONVREAL 00016 #endif 00017 00018 module fortoutput_module 00019 use xmpi_module 00020 use mnemmodule 00021 use means_module 00022 00023 implicit none 00024 private 00025 public var_output_init, var_output 00026 00027 ! Robert: Add choice of output variables 00028 !logical,dimension(999) :: outputindex ! [-] tracks which global variables are to be outputted. 00029 00030 integer*4,dimension(:),allocatable,save :: crosstype ! 0 = cross shore (x), 1 = longshore (y) 00031 integer*4,dimension(:),allocatable,save :: xpoints ! model x-coordinate of output points 00032 integer*4,dimension(:),allocatable,save :: ypoints ! model y-coordinate of output points 00033 integer*4,dimension(:),allocatable,save :: xcross ! model x-coordinate of output cross sections 00034 integer*4,dimension(:),allocatable,save :: ycross ! model y-coordinate of output cross sections 00035 integer*4,dimension(:),allocatable,save :: nvarcross ! vector with number of output variable per output cross section 00036 integer*4,dimension(:,:),allocatable,save:: Avarpoint ! Array with associated index of output variables per point 00037 integer*4,dimension(:,:),allocatable,save:: Avarcross ! Array with associated index of output variables per cross section 00038 integer*4,dimension(:,:),allocatable,save:: rugmaskg,rugmaskl ! Mask with 1 for row with runup gauge, 0 without. Dimensions: nx+1,ny+1 00039 ! One for global field, one for mpi subdomain if using MPI 00040 integer*4,dimension(:),allocatable,save :: rugrowindex ! Array with row index where runup gauge can be found 00041 ! Only alive at xmaster 00042 integer*4,save :: stpm ! size of tpm 00043 00044 ! Store the global variables in numbers.... 00045 integer,save :: noutnumbers = 0 ! the number of outnumbers 00046 integer, dimension(numvars),save :: outnumbers ! numbers, corrsponding to mnemonics, which are to be output 00047 00048 00049 integer :: itg,itp,itc,itm,itd,day,ot 00050 type(arraytype) :: At 00051 00052 interface outarray 00053 module procedure outarray_r0 00054 module procedure outarray_r1 00055 module procedure outarray_r2 00056 module procedure outarray_r3 00057 module procedure outarray_r4 00058 module procedure outarray_i0 00059 module procedure outarray_i1 00060 module procedure outarray_i2 00061 module procedure outarray_i3 00062 module procedure outarray_i4 00063 end interface outarray 00064 00065 contains 00066 00067 00068 00069 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00070 !!!!!!!!!!!!!!!!!!! INITIALISE OUTPUT !!!!!!!!!!!!!!!!!!!!!!!!!!!! 00071 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00072 00073 00074 00075 subroutine var_output_init(s,sl,par,tpar) 00076 use params, only: parameters 00077 use spaceparams 00078 use readkey_module 00079 use timestep_module 00080 use logging_module 00081 use postprocessmod 00082 use filefunctions 00083 #ifdef USEMPI 00084 use general_mpi_module 00085 #endif 00086 00087 IMPLICIT NONE 00088 00089 type(spacepars),intent(in) :: s,sl 00090 type(parameters),intent(in) :: par 00091 type(timepars),intent(in) :: tpar 00092 00093 integer :: i,j 00094 integer :: i1,i2,i3 00095 integer :: reclen,reclenp,wordsize,reclenm 00096 integer :: fid 00097 character(99) :: fname,fnamemean,fnamevar,fnamemin,fnamemax 00098 type(arraytype) :: t 00099 00100 #ifdef USEMPI 00101 logical :: toall = .true. 00102 #endif 00103 00104 reclenm = -123 00105 00106 ! Initialize places in output files 00107 itg = 0 00108 itm = 0 00109 itp = 0 00110 itc = 0 00111 itd = 0 00112 stpm = size(tpar%tpm) 00113 00114 ! Record size for global and mean output 00115 inquire(iolength=wordsize) CONVREAL(1.d0) 00116 reclen=wordsize*(s%nx+1)*(s%ny+1) 00117 00118 !!!!! XY.DAT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00119 00120 00121 00122 if (xomaster) then 00123 open(100,file='xy.dat',form='unformatted',access='direct',recl=reclen,status='REPLACE') 00124 write(100,rec=1)CONVREAL(s%xz) 00125 write(100,rec=2)CONVREAL(s%yz) 00126 write(100,rec=3)CONVREAL(s%x) 00127 write(100,rec=4)CONVREAL(s%y) 00128 close(100) 00129 endif 00130 00131 !!!!! GLOBAL VARS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00132 00133 ! This module identifies output variables by their index 00134 ! store this at the module level so we don't have to pass par around 00135 ! do i=1,size(par%globalvars) 00136 ! if (trim(par%globalvars(i))=='abc') then 00137 ! exit 00138 ! endif 00139 ! enddo 00140 noutnumbers = par%nglobalvar 00141 ! store all indices for the global variables 00142 do i= 1,noutnumbers 00143 outnumbers(i) = chartoindex(par%globalvars(i)) 00144 enddo 00145 00146 #ifdef USEMPI 00147 call xmpi_bcast(noutnumbers,toall) 00148 call xmpi_bcast(outnumbers,toall) 00149 #endif 00150 00151 !!!!! OUTPUT POINTS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00152 ! read from par to local 00153 if (par%npoints + par%nrugauge > 0) then 00154 allocate(xpoints(par%npoints+par%nrugauge)) 00155 allocate(ypoints(par%npoints+par%nrugauge)) 00156 ! 3 for rugauge, npointvar for points 00157 allocate(Avarpoint(par%npoints+par%nrugauge,max(par%npointvar,par%nrugdepth*3))) 00158 xpoints=0 00159 ypoints=0 00160 00161 ! Convert world coordinates of points to nearest (lsm) grid point 00162 if (xmaster) then 00163 call snappointstogrid(par, s, xpoints, ypoints) 00164 do i=1,par%npoints 00165 do j=1,par%npointvar 00166 Avarpoint(i,j) = chartoindex(trim(par%pointvars(j))) 00167 end do 00168 end do 00169 do i=par%npoints+1,par%npoints+par%nrugauge 00170 Avarpoint(i,1) = chartoindex('xz') 00171 Avarpoint(i,2) = chartoindex('yz') 00172 Avarpoint(i,3) = chartoindex('zs') 00173 enddo 00174 endif 00175 #ifdef USEMPI 00176 call xmpi_bcast(xpoints,toall) 00177 call xmpi_bcast(ypoints,toall) 00178 call xmpi_bcast(Avarpoint,toall) 00179 #endif 00180 ! make mask for grid rows which include 00181 if (par%nrugauge>0) then 00182 allocate(rugrowindex(par%nrugauge)) 00183 #ifdef USEMPI 00184 allocate(rugmaskg(s%nx+1,s%ny+1)) 00185 allocate(rugmaskl(sl%nx+1,sl%ny+1)) 00186 #endif 00187 ! Make rugrowindex with row number (per subprocess) with runup gauge 00188 do i=1,par%nrugauge 00189 #ifndef USEMPI 00190 ! very easy 00191 rugrowindex(i)=ypoints(par%npoints+i) 00192 #else 00193 ! very complicated 00194 if (xmaster .or. xomaster) then 00195 ! generate rugmask on global grid 00196 do j=1,s%ny+1 00197 if (j==ypoints(par%npoints+i)) then 00198 rugmaskg(:,j)=1 00199 else 00200 rugmaskg(:,j)=0 00201 endif 00202 enddo 00203 endif 00204 ! now distribute rugmask global to rugmask local on all subgrids 00205 if(xcompute) then 00206 call matrix_distr(rugmaskg,rugmaskl,sl%is,sl%lm,sl%js,sl%ln,xmpi_master,xmpi_comm) 00207 endif 00208 ! everybody has their own rugmaskl. Look to see if your domain has "1" in rugmaskl 00209 ! first assume that no runup gauge exists in this domain, so we set rowindex to zero 00210 rugrowindex(i)=0 ! rugrowindex is local on all subgrid 00211 if (xcompute) then ! rugmaskl has no meaning on xomaster 00212 do j=1,sl%ny+1 00213 if (rugmaskl(1,j)==1) rugrowindex(i)=j ! okay, there is a runup gauge this row 00214 enddo 00215 endif 00216 #endif 00217 enddo ! i=1,par%nrugauge 00218 #ifdef USEMPI 00219 deallocate(rugmaskg) ! not needed anymore 00220 deallocate(rugmaskl) ! not needed anymore 00221 #endif 00222 endif ! runup gauge > 0 00223 ! 00224 ! First time file opening for point output 00225 ! 00226 if (xomaster) then 00227 do i=1,par%npoints+par%nrugauge 00228 fname = '' 00229 if (par%pointtypes(i)==0) then 00230 fname(1:5)='point' 00231 i1=floor(real(i)/100.d0) 00232 i2=floor(real(i-i1*100)/10.d0) 00233 i3=i-i1*100-i2*10 00234 else 00235 fname(1:5)='rugau' 00236 i1=floor(real(i-par%npoints)/100.d0) 00237 i2=floor(real((i-par%npoints)-i1*100)/10.d0) 00238 i3=(i-par%npoints)-i1*100-i2*10 00239 endif 00240 fname(6:6)=char(48+i1) 00241 fname(7:7)=char(48+i2) 00242 fname(8:8)=char(48+i3) 00243 fname(9:12)='.dat' 00244 if (par%pointtypes(i)==0) then 00245 reclenp=wordsize*(par%npointvar+1)*1 00246 else 00247 reclenp=wordsize*(1+par%nrugdepth*3)*1 00248 endif 00249 open(indextopointsunit(i),file=fname,& 00250 form='unformatted',access='direct',recl=reclenp,status='REPLACE') 00251 enddo 00252 if (par%npoints>0) then 00253 ! write index file of point output variables 00254 fid=create_new_fid() 00255 open(fid,file='pointvars.idx',status='replace',action='write') 00256 do i=1,par%npointvar 00257 write(fid,*)trim(par%pointvars(i)) 00258 enddo 00259 close(fid) 00260 endif 00261 endif ! xomaster 00262 end if ! npoints+nrugauge>0 00263 00264 00265 !!!!! TIME-AVEARGE, VARIANCE and MIN-MAX ARRAYS!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00266 00267 00268 00269 if (par%nmeanvar>0) then 00270 !! First time file opening for time-average output 00271 if(xomaster) then 00272 do i=1,par%nmeanvar 00273 call makeaveragenames(chartoindex(trim(par%meanvars(i))),fnamemean,fnamevar,fnamemin,fnamemax) 00274 fnamemean=trim(fnamemean) 00275 fnamevar =trim(fnamevar) 00276 fnamemin =trim(fnamemin) 00277 fnamemax =trim(fnamemax) 00278 call indextos(s,chartoindex(trim(par%meanvars(i))),t) 00279 reclenm = wordsize 00280 select case(t%rank) 00281 case (2) 00282 reclenm = wordsize*size(t%r2) 00283 case (3) 00284 reclenm=wordsize*size(t%r3) 00285 case (4) 00286 reclenm=wordsize*size(t%r4) 00287 end select 00288 open(indextomeanunit(i),file=fnamemean,form='unformatted',access='direct',recl=reclenm,status='REPLACE') 00289 open(indextovarunit(i) ,file=fnamevar ,form='unformatted',access='direct',recl=reclenm,status='REPLACE') 00290 open(indextominunit(i) ,file=fnamemin ,form='unformatted',access='direct',recl=reclenm,status='REPLACE') 00291 open(indextomaxunit(i),file=fnamemax, form='unformatted',access='direct',recl=reclenm,status='REPLACE') 00292 enddo 00293 endif 00294 endif ! par%nmeanvar > 0 00295 00296 00297 ! 00298 ! drifter output files 00299 ! 00300 if (par%ndrifter>0) then 00301 if (xomaster) then 00302 inquire(iolength=wordsize) CONVREAL(1.d0) 00303 00304 reclen=wordsize*3 00305 do i=1,par%ndrifter 00306 write(fname(7:10),'(i4)')i+1000 00307 fname(1:7)='drifter' 00308 fname(11:14)='.dat' 00309 open(indextodrifterunit(i),file=fname,form='unformatted',access='direct',recl=reclen,status='REPLACE') 00310 enddo 00311 endif 00312 endif ! par%ndrifter >0 00313 ! wwvv to avoid warning about unused sl: 00314 if (sl%nx .eq. -1) return 00315 00316 end subroutine var_output_init 00317 00318 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00319 !!!!!!!!!!!!!!!! OUTPUT AT EVERY TIMESTEP !!!!!!!!!!!!!!!!!!!!!!!! 00320 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00321 00322 00323 subroutine var_output(s,sl,par,tpar) 00324 use params, only: parameters 00325 use spaceparams 00326 use timestep_module 00327 use logging_module 00328 #ifdef USEMPI 00329 use xmpi_module 00330 #endif 00331 00332 IMPLICIT NONE 00333 00334 type(spacepars) :: s,sl 00335 type(parameters) :: par 00336 type(timepars),intent(in) :: tpar 00337 integer :: i,ii,ird 00338 ! integer :: i1,i2,i3 00339 integer :: wordsize,idumhl 00340 integer :: xmax 00341 #ifdef USEMPI 00342 integer :: xrank 00343 #endif 00344 real*8,dimension(numvars) :: intpvector 00345 real*8,dimension(numvars,s%nx+1) :: crossvararray0 00346 real*8,dimension(numvars,s%ny+1) :: crossvararray1 00347 integer,dimension(:),allocatable :: tempvectori 00348 real*8,dimension(:),allocatable :: tempvectorr 00349 real*8,dimension(size(tpar%tpg)+size(tpar%tpp)+size(tpar%tpc)+size(tpar%tpm)) :: outputtimes 00350 type(arraytype) :: t 00351 00352 integer :: iz,jz 00353 real*8 :: di,dj,dx,dy 00354 00355 #ifdef USEMPI 00356 logical :: toall = .true. 00357 #endif 00358 00359 #ifdef USEMPI 00360 xrank = huge(xrank) 00361 #endif 00362 inquire(iolength=wordsize) CONVREAL(1.d0) 00363 ! reclen=wordsize*(s%nx+1)*(s%ny+1) 00364 ! reclen2=wordsize*(s%nx+1)*(s%ny+1)*(par%ngd)*(par%nd) 00365 00366 ! Determine if this is an output timestep 00367 if (tpar%output) then 00368 !!! Write at every output timestep 00369 00370 !!! Write point variables 00371 !!! Only write if it is output time for points 00372 if (par%npoints+par%nrugauge>0) then 00373 00374 !! Runup gauge depth 00375 00376 if (tpar%outputp) then 00377 itp=itp+1 00378 ! 00379 ! Set up runup gauge output vector 00380 allocate(tempvectorr(1+par%nrugdepth*3)) 00381 tempvectorr=huge(0.d0) 00382 do i=1,par%nrugauge 00383 do ird=1,par%nrugdepth 00384 ! in MPI we only want to cycle through sub matrix, else through whole matrix 00385 #ifdef USEMPI 00386 xmax = sl%nx+1 00387 xrank = huge(xrank) ! Set default, so processes not involved in 00388 ! runup gauge do not affect all_reduce statement 00389 idumhl = xmax ! Set default 00390 if (rugrowindex(i)>0) then ! this (sub) domain contains this runup gauge 00391 ! local index of minimum location where hh<rugdepth 00392 do ii=2,xmax 00393 if ((sl%hh(ii,rugrowindex(i))<=par%rugdepth(ird)) .and. & 00394 (sl%hh(ii-1,rugrowindex(i))>par%rugdepth(ird)) ) then 00395 idumhl= ii-1 00396 xrank = xmpi_rank ! the row number of this process in the MPI grid of subdomains 00397 exit 00398 endif 00399 enddo 00400 endif 00401 #else 00402 xmax = s%nx+1 00403 idumhl = xmax ! Set default 00404 if (rugrowindex(i)>0) then ! master domain always contains this runup gauge 00405 ! local index of minimum location where hh<rugdepth 00406 do ii=2,xmax 00407 if ((s%hh(ii,rugrowindex(i))<=par%rugdepth(ird)) .and. & 00408 (s%hh(ii-1,rugrowindex(i))>par%rugdepth(ird)) ) then 00409 idumhl=ii-1 00410 exit 00411 endif 00412 enddo 00413 endif 00414 #endif 00415 00416 #ifdef USEMPI 00417 ! In MPI multiple domains may have a non-zero value for idumhl, so we choose the one with the 00418 ! lowest MPI rank (closest to xmpi_top, or the offshore boundary) 00419 !call xmpi_allreduce(xrank,MPI_MIN) ! wwvv-todo 00420 ! now only look at this process 00421 !if (xmpi_rank==xrank) then 00422 if(xmaster) then 00423 if (par%morfacopt==1) then 00424 tempvectorr(1)=par%t*max(par%morfac,1.d0) 00425 else 00426 tempvectorr(1)=par%t 00427 endif 00428 tempvectorr((ird-1)*3+2)=sl%x(idumhl,rugrowindex(i)) 00429 tempvectorr((ird-1)*3+3)=sl%y(idumhl,rugrowindex(i)) 00430 tempvectorr((ird-1)*3+4)=sl%zs(idumhl,rugrowindex(i)) 00431 endif 00432 ! Reduce the whole set to only the real numbers in tempvectori in xmpi_rank 00433 ! wwvv this only works, because the lowest rank belongs to xmaster 00434 if(xcompute) call xmpi_allreduce(tempvectorr,MPI_MIN) 00435 ! wwvv xomaster needs this tempvectorr: 00436 call xmpi_bcast(tempvectorr,toall) ! wwvv should make a allreduce toall 00437 #else 00438 if (par%morfacopt==1) then 00439 tempvectorr(1)=par%t*max(par%morfac,1.d0) 00440 else 00441 tempvectorr(1)=par%t 00442 endif 00443 tempvectorr((ird-1)*3+2)=s%xz(idumhl,rugrowindex(i)) 00444 tempvectorr((ird-1)*3+3)=s%yz(idumhl,rugrowindex(i)) 00445 tempvectorr((ird-1)*3+4)=s%zs(idumhl,rugrowindex(i)) 00446 #endif 00447 enddo 00448 if (xomaster) write(indextopointsunit(i+par%npoints),rec=itp)CONVREAL(tempvectorr) 00449 enddo ! i=1,par%nrugauge 00450 deallocate(tempvectorr) 00451 00452 !! point output 00453 00454 do i=1,par%npoints 00455 !!! Make vector of all s% values at n,m grid coordinate 00456 call makeintpvector(par,sl,intpvector,xpoints(i),ypoints(i)) 00457 if (xomaster) then 00458 allocate(tempvectori(par%npointvar)) 00459 tempvectori=Avarpoint(i,1:par%npointvar) 00460 allocate(tempvectorr(par%npointvar+1)) 00461 tempvectorr=0.d0 00462 do ii=1,par%npointvar 00463 tempvectorr(ii+1)=intpvector(tempvectori(ii)) 00464 enddo 00465 if (par%morfacopt==1) then 00466 tempvectorr(1)=par%t*max(par%morfac,1.d0) 00467 else 00468 tempvectorr(1)=par%t 00469 endif 00470 write(indextopointsunit(i),rec=itp)CONVREAL(tempvectorr) 00471 deallocate(tempvectori) 00472 deallocate(tempvectorr) 00473 endif 00474 enddo 00475 endif 00476 endif 00477 00478 !!! Collect mean variable to global grid 00479 if (par%nmeanvar>0) then 00480 ! Not at the first in tpm as this is the start of averaging. Only output after second in tpm 00481 if (tpar%outputm .and. tpar%itm>1) then 00482 do i=1,par%nmeanvar 00483 #ifdef USEMPI 00484 call means_collect(sl,meansparsglobal(i),meansparslocal(i)) 00485 #else 00486 meansparsglobal(i)=meansparslocal(i) 00487 #endif 00488 enddo 00489 endif 00490 endif 00491 !!! Write average variables 00492 00493 if (par%nmeanvar>0) then 00494 ! Not at the first in tpm as this is the start of averaging. Only output after second in tpm 00495 if (tpar%outputm .and. tpar%itm>1) then 00496 itm=itm+1 ! Note, this is a local counter, used to position in output file 00497 do i=1,par%nmeanvar 00498 select case (meansparsglobal(i)%rank) 00499 case (2) 00500 if(xomaster) then 00501 if (trim(par%meanvars(i))=='H') then ! Hrms changed to H 00502 write(indextomeanunit(i),rec=itm)CONVREAL(sqrt(meansparsglobal(i)%variancesquareterm2d)) 00503 elseif (trim(par%meanvars(i))=='urms') then ! urms 00504 write(indextomeanunit(i),rec=itm)CONVREAL(sqrt(meansparsglobal(i)%variancesquareterm2d)) 00505 elseif (trim(par%meanvars(i))=='thetamean') then ! thetamean 00506 write(indextomeanunit(i),rec=itm) & 00507 CONVREAL( & 00508 mod(2.d0*par%px + atan2(nint(meansparsglobal(i)%mean2d)/1d7, & 00509 mod(meansparsglobal(i)%mean2d,1.d0)*1d1), 2.d0*par%px) / par%px * 180 & 00510 ) 00511 else ! non-rms variables 00512 write(indextomeanunit(i),rec=itm)CONVREAL(meansparsglobal(i)%mean2d) 00513 endif 00514 write(indextovarunit(i),rec=itm)CONVREAL(meansparsglobal(i)%variance2d) 00515 where(meansparsglobal(i)%min2d>0.99d0*huge(0.d0)) 00516 meansparsglobal(i)%min2d=-999.d0 00517 endwhere 00518 where(meansparsglobal(i)%max2d<-0.99d0*huge(0.d0)) 00519 meansparsglobal(i)%max2d=-999.d0 00520 endwhere 00521 write(indextominunit(i),rec=itm)CONVREAL(meansparsglobal(i)%min2d) 00522 write(indextomaxunit(i),rec=itm)CONVREAL(meansparsglobal(i)%max2d) 00523 endif 00524 case (3) 00525 if(xomaster) then 00526 write(indextomeanunit(i),rec=itm)CONVREAL(meansparsglobal(i)%mean3d) 00527 write(indextovarunit(i),rec=itm)CONVREAL(meansparsglobal(i)%variance3d) 00528 where(meansparsglobal(i)%min3d>0.99d0*huge(0.d0)) 00529 meansparsglobal(i)%min3d=-999.d0 00530 endwhere 00531 where(meansparsglobal(i)%max3d<-0.99d0*huge(0.d0)) 00532 meansparsglobal(i)%max3d=-999.d0 00533 endwhere 00534 write(indextominunit(i),rec=itm)CONVREAL(meansparsglobal(i)%min3d) 00535 write(indextomaxunit(i),rec=itm)CONVREAL(meansparsglobal(i)%max3d) 00536 endif 00537 case (4) 00538 if(xomaster) then 00539 write(indextomeanunit(i),rec=itm)CONVREAL(meansparsglobal(i)%mean4d) 00540 write(indextovarunit(i),rec=itm)CONVREAL(meansparsglobal(i)%variance4d) 00541 where(meansparsglobal(i)%min4d>0.99d0*huge(0.d0)) 00542 meansparsglobal(i)%min4d=-999.d0 00543 endwhere 00544 where(meansparsglobal(i)%max4d<-0.99d0*huge(0.d0)) 00545 meansparsglobal(i)%max4d=-999.d0 00546 endwhere 00547 write(indextominunit(i),rec=itm)CONVREAL(meansparsglobal(i)%min4d) 00548 write(indextomaxunit(i),rec=itm)CONVREAL(meansparsglobal(i)%max4d) 00549 endif 00550 end select 00551 enddo 00552 endif ! t output 00553 par%tintm=tpar%tpm(min(itm+2,stpm))-tpar%tpm(itm+1) ! Next averaging period (min to stop array out of bounds) 00554 par%tintm=max(par%tintm,tiny(0.d0)) ! to prevent par%tintm=0 after last output 00555 endif ! nmeanvar > 0 00556 00557 00558 !!! Write global variables 00559 if (par%nglobalvar/=0) then 00560 if (tpar%outputg) then 00561 itg=itg+1 00562 do i = 1,par%nglobalvar 00563 #ifdef USEMPI 00564 call space_collect_index(s,sl,par,outnumbers(i)) 00565 #endif 00566 if(xomaster) then 00567 call indextos(s,outnumbers(i),t) 00568 select case(t%type) 00569 case ('r') 00570 select case(t%rank) 00571 case(0) 00572 call outarray(i,t%r0) 00573 case(1) 00574 call outarray(i,t%r1) 00575 case(2) 00576 call outarray(s,i,t%r2) 00577 case(3) 00578 call outarray(s,i,t%r3) 00579 case(4) 00580 call outarray(i,t%r4) 00581 end select 00582 case('i') 00583 select case(t%rank) 00584 case(0) 00585 call outarray(i,t%i0) 00586 case(1) 00587 call outarray(i,t%i1) 00588 case(2) 00589 call outarray(i,t%i2) 00590 case(3) 00591 call outarray(i,t%i3) 00592 case(4) 00593 call outarray(i,t%i4) 00594 end select 00595 end select 00596 endif ! xomaster 00597 enddo ! outnumber loop 00598 endif 00599 endif ! end global file writing 00600 00601 ! 00602 ! write drifter output 00603 ! 00604 00605 #ifdef USEMPI 00606 ! to send sl%idrift from xmaster to xomaster 00607 ! wwvv todo use xmpi_send for this 00608 call xmpi_bcast(sl%idrift,toall) 00609 ! wwvv todo shouldn't we send also sl%jdrift ? 00610 call xmpi_bcast(sl%jdrift,toall) 00611 #endif 00612 if (xomaster) then 00613 00614 #ifdef USEMPI 00615 s%idrift = sl%idrift 00616 s%jdrift = sl%jdrift 00617 #endif 00618 00619 if (abs(mod(par%t,par%tintp))<1.d-6) then 00620 itd = itd+1 00621 do i=1,par%ndrifter 00622 if ( par%t>=s%tdriftb(i) .and. par%t<=s%tdrifte(i) .and. & 00623 s%idrift(i)>1 .and. s%idrift(i)<=s%nx .and. & 00624 s%jdrift(i)>1 .and. s%jdrift(i)<=s%ny ) then 00625 00626 iz = int(s%idrift(i)) 00627 jz = int(s%jdrift(i)) 00628 00629 di = mod(s%idrift(i),1.d0) 00630 dj = mod(s%jdrift(i),1.d0) 00631 00632 dx = di*s%dsu(iz,jz)*cos(s%alfaz(iz,jz)) - & 00633 dj*s%dnv(iz,jz)*sin(s%alfaz(iz,jz)) 00634 dy = di*s%dsu(iz,jz)*sin(s%alfaz(iz,jz)) + & 00635 dj*s%dnv(iz,jz)*cos(s%alfaz(iz,jz)) 00636 00637 write(indextodrifterunit(i),rec=itd) & 00638 CONVREAL(s%xz(iz,jz)+dx), & 00639 CONVREAL(s%yz(iz,jz)+dy), & 00640 CONVREAL(par%t) 00641 else 00642 write(indextodrifterunit(i),rec=itd) & 00643 CONVREAL(-999d0), & 00644 CONVREAL(-999d0), & 00645 CONVREAL(par%t) 00646 endif 00647 enddo 00648 endif 00649 endif 00650 00651 if(xomaster) then 00652 outputtimes=-999.d0 00653 outputtimes(1:itg)=tpar%tpg(1:itg) 00654 outputtimes(itg+1:itg+itp)=tpar%tpp(1:itp) 00655 outputtimes(itg+itp+1:itg+itp+itc)=tpar%tpc(1:itc) 00656 outputtimes(itg+itp+itc+1:itg+itp+itc+itm)=tpar%tpm(2:itm+1) ! mean output always shifted by 1 00657 if (par%morfacopt==1) outputtimes=outputtimes*max(par%morfac,1.d0) 00658 open(999,file='dims.dat',form='unformatted',access='direct',recl=wordsize*(10+size(outputtimes))) 00659 write(999,rec=1) CONVREAL(itg*1.d0),& 00660 CONVREAL(s%nx*1.d0),& 00661 CONVREAL(s%ny*1.d0),& 00662 CONVREAL(s%ntheta*1.d0),& 00663 CONVREAL(par%kmax*1.d0),& 00664 CONVREAL(par%ngd*1.d0),& 00665 CONVREAL(par%nd*1.d0), & 00666 CONVREAL(tpar%itp*1.d0),& 00667 CONVREAL(itc*1.d0),& 00668 CONVREAL(itm*1.d0),& 00669 CONVREAL(outputtimes) 00670 call flush(999) 00671 ! Just output for MICORE for backwards compat 00672 ! open(999,file='dims.dat',form='unformatted',access='direct',recl=wordsize*(7+size(outputtimes))) 00673 ! write(999,rec=1)itg*1.d0,& 00674 ! s%nx*1.d0,& 00675 ! s%ny*1.d0,& 00676 ! par%ngd*1.d0,& 00677 ! par%nd*1.d0, & 00678 ! itp*1.d0,& 00679 ! itm*1.d0,& 00680 ! outputtimes 00681 ! close(999) 00682 endif !xomaster 00683 00684 end if ! 00685 00686 !!! Close files 00687 00688 if(xomaster) then 00689 if(par%t>=par%tstop) then 00690 do i=1,par%npoints+par%nrugauge 00691 close(indextopointsunit(i)) 00692 enddo 00693 00694 do i=1,par%nmeanvar 00695 close(indextomeanunit(i)) 00696 close(indextovarunit(i)) 00697 close(indextominunit(i)) 00698 close(indextomaxunit(i)) 00699 enddo 00700 00701 do i=1,par%ndrifter 00702 close (indextodrifterunit(i)) 00703 enddo 00704 00705 do i=1,noutnumbers 00706 close (indextoglobalunit(i)) 00707 enddo 00708 end if 00709 endif 00710 ! wwvv to avoid warning about unused xrank: 00711 #ifdef USEMPI 00712 if (xrank .eq. -1) return 00713 #endif 00714 00715 end subroutine var_output 00716 00717 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00718 !!!!!!!!!!!!!!!!!!! INTERNAL SUBROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!! 00719 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00720 00721 00722 00723 subroutine makeintpvector(par,s,intpvector,mg,ng) 00724 00725 use params, only: parameters 00726 use spaceparams 00727 use logging_module 00728 00729 IMPLICIT NONE 00730 00731 type(parameters), intent(in) :: par 00732 type(spacepars), intent(in) :: s ! need slocal here, because 00733 ! the is,js lm and ln arrays 00734 ! on the not-master nodes 00735 ! are only in slocal 00736 real*8,dimension(:) :: intpvector 00737 integer,intent(in) :: mg,ng 00738 00739 type(arraytype) :: t 00740 integer :: j,m,n 00741 real*8 :: value 00742 00743 #ifdef USEMPI 00744 integer :: i,p,ierr 00745 logical :: toall = .true. 00746 #endif 00747 00748 m = mg 00749 n = ng 00750 00751 #ifdef USEMPI 00752 ! 00753 ! wwvv argh! for performance, we will not collect each 00754 ! matrix or block to master. Each process has to 00755 ! determine if it has the values, and then send them. 00756 ! 00757 ! locate the process who has index m 00758 00759 p=-1 00760 do i=1,xmpi_size 00761 ! if (mg .ge. s%is(i) .and. mg .le. s%is(i) + s%lm(i) .and. & 00762 ! ng .ge. s%js(i) .and. ng .le. s%js(i) + s%ln(i)) then 00763 ! Change suggested by Jim Gunson: 00764 if (mg .ge. s%is(i) .and. mg .lt. s%is(i) + s%lm(i) .and. & 00765 ng .ge. s%js(i) .and. ng .lt. s%js(i) + s%ln(i)) then 00766 ! if (mg .ge. s%icgs(i) .and. mg .le. s%icge(i) .and. ng .ge. s%jcgs(i) .and. ng .le. s%jcge(i)) then 00767 ! wwvv-todo ? 00768 m = mg - s%is(i) + 1 ! m and n now the indices for process p 00769 n = ng - s%js(i) + 1 00770 p = i-1 00771 exit 00772 endif 00773 enddo 00774 if (p .lt. 0) then 00775 call writelog('els','','Catastrophic error in makeintpvector') 00776 call writelog('els','(a,i0,",",i0)','Cannot find processor for indexes ',mg,ng) 00777 call halt_program 00778 endif 00779 00780 00781 if (xmpi_rank .eq. p) then 00782 #endif 00783 do j=1,numvars 00784 call indextos(s,j,t) 00785 value = -999 ! default 00786 select case (t%name) 00787 case(mnem_thetamean) 00788 ! value = 270-((s%thetamean(m,n)+s%alfaz(m,n))*(180/par%px)) ! iwwvv thetamean: is that 00789 value = 270-((s%thetamean(m,n))*(180/par%px)) ! iwwvv thetamean: is that 00790 ! different on each 00791 ! process? 00792 case(mnem_Fx) 00793 value = s%Fx(m,n)*cos(s%alfaz(m,n))-s%Fy(m,n)*sin(s%alfaz(m,n)) 00794 case(mnem_Fy) 00795 value = s%Fx(m,n)*sin(s%alfaz(m,n))+s%Fy(m,n)*cos(s%alfaz(m,n)) 00796 case(mnem_u) 00797 value = s%u(m,n)*cos(s%alfaz(m,n))-s%v(m,n)*sin(s%alfaz(m,n)) 00798 case(mnem_gwu) 00799 value = s%gwu(m,n)*cos(s%alfaz(m,n))-s%gwv(m,n)*sin(s%alfaz(m,n)) 00800 case(mnem_v) 00801 value = s%u(m,n)*sin(s%alfaz(m,n))+s%v(m,n)*cos(s%alfaz(m,n)) 00802 case(mnem_gwv) 00803 value = s%gwu(m,n)*sin(s%alfaz(m,n))+s%gwv(m,n)*cos(s%alfaz(m,n)) 00804 case(mnem_ue) 00805 value = s%ue(m,n)*cos(s%alfaz(m,n))-s%ve(m,n)*sin(s%alfaz(m,n)) 00806 case(mnem_ve) 00807 value = s%ue(m,n)*sin(s%alfaz(m,n))+s%ve(m,n)*cos(s%alfaz(m,n)) 00808 case(mnem_uwf) 00809 value = s%uwf(m,n)*cos(s%alfaz(m,n))-s%vwf(m,n)*sin(s%alfaz(m,n)) 00810 case(mnem_vwf) 00811 value = s%uwf(m,n)*sin(s%alfaz(m,n))+s%vwf(m,n)*cos(s%alfaz(m,n)) 00812 case(mnem_ui) 00813 value = s%ui(m,n)*cos(s%alfaz(m,n))-s%vi(m,n)*sin(s%alfaz(m,n)) 00814 case(mnem_vi) 00815 value = s%ui(m,n)*sin(s%alfaz(m,n))+s%vi(m,n)*cos(s%alfaz(m,n)) 00816 case(mnem_umean) 00817 value = s%umean(m,n)*cos(s%alfaz(m,n))-s%vmean(m,n)*sin(s%alfaz(m,n)) 00818 case(mnem_vmean) 00819 value = s%umean(m,n)*sin(s%alfaz(m,n))+s%vmean(m,n)*cos(s%alfaz(m,n)) 00820 case default 00821 select case(t%rank) 00822 case (0) 00823 if (t%type .eq.'i') then 00824 value = dble(t%i0) 00825 else 00826 value = t%r0 00827 endif 00828 case(1) 00829 if (t%type .eq. 'r') then 00830 select case(t%name) 00831 case default 00832 continue 00833 ! case (mnem_yz,mnem_yv) 00834 ! value = t%r1(n) 00835 ! case (mnem_xz,mnem_xu) 00836 ! value = t%r1(m) 00837 end select 00838 endif 00839 case (2) 00840 if (t%type .eq. 'i') then 00841 if (m .le. size(t%i2,1) .and. n .le. size(t%i2,2)) then 00842 value = dble(t%i2(m,n)) 00843 endif 00844 else 00845 if (m .le. size(t%r2,1) .and. n .le. size(t%r2,2)) then 00846 value = t%r2(m,n) 00847 endif 00848 endif 00849 end select 00850 end select 00851 intpvector(j) = value 00852 enddo 00853 #ifdef USEMPI 00854 endif 00855 ! 00856 ! process p has now the intptvector (hopefully!) 00857 ! send it now to the master with a simpel send, 00858 ! master will receive this 00859 ! This is not necessary if master has everything 00860 ! 00861 ! p is the rank in xmpi_comm 00862 ! what is the rank in xmpi_ocomm? 00863 ! for the time being, assume that that is 00864 ! p(xmpi_comm) + 1 00865 ! 00866 p = p + 1 00867 if (p .ne. xmpi_omaster) then 00868 if (xmpi_orank .eq. p) then 00869 call MPI_Send(intpvector, numvars, MPI_DOUBLE_PRECISION, xmpi_omaster, & 00870 311, xmpi_ocomm, ierr) 00871 endif 00872 if (xomaster) then 00873 call MPI_Recv(intpvector, numvars, MPI_DOUBLE_PRECISION, p, & 00874 311, xmpi_ocomm, MPI_STATUS_IGNORE, ierr) 00875 endif 00876 ! this barrier is really needed: 00877 call xmpi_barrier(toall) 00878 endif 00879 #endif 00880 end subroutine makeintpvector 00881 00882 00883 00884 00885 00886 00887 subroutine outarray_r0(index,x) 00888 implicit none 00889 integer :: index 00890 real*8,intent(in) :: x 00891 integer :: unit,reclen,jtg 00892 00893 inquire(iolength=reclen) CONVREAL(x) 00894 call checkfile(index,unit,reclen,jtg) 00895 00896 write(unit,rec=jtg) CONVREAL(x) 00897 00898 end subroutine outarray_r0 00899 00900 subroutine outarray_r1(index,x) 00901 implicit none 00902 integer :: index 00903 real*8, dimension(:), pointer :: x 00904 integer :: unit,reclen,jtg 00905 character*20 :: mnem 00906 real*8, parameter :: pi = 4*atan(1.0d0) 00907 00908 inquire(iolength=reclen) CONVREAL(x) 00909 call checkfile(index,unit,reclen,jtg) 00910 00911 mnem = mnemonics(outnumbers(index)) 00912 if (mnem .eq. mnem_theta .or. & 00913 mnem .eq. mnem_theta0 ) then 00914 write(unit,rec=jtg) CONVREAL(270-(x*(180/pi))) 00915 else 00916 write(unit,rec=jtg) CONVREAL(x) 00917 endif 00918 00919 end subroutine outarray_r1 00920 00921 subroutine outarray_r2(s,index,x) 00922 use spaceparams 00923 implicit none 00924 type(spacepars),intent(in) :: s 00925 integer :: index 00926 real*8, dimension(:,:), pointer :: x 00927 integer :: unit,reclen,jtg 00928 character*20 :: mnem 00929 real*8, parameter :: pi = 4*atan(1.0d0) 00930 00931 inquire(iolength=reclen) CONVREAL(x) 00932 call checkfile(index,unit,reclen,jtg) 00933 00934 mnem = mnemonics(outnumbers(index)) 00935 00936 select case(mnem) 00937 case(mnem_thetamean) 00938 write(unit,rec=jtg)CONVREAL(270-((x)*(180/pi))) 00939 case(mnem_Fx) 00940 write(unit,rec=jtg)CONVREAL(x*cos(s%alfaz)-s%Fy*sin(s%alfaz)) 00941 case(mnem_Fy) 00942 write(unit,rec=jtg)CONVREAL(s%Fx*sin(s%alfaz)+x*cos(s%alfaz)) 00943 case(mnem_u) 00944 write(unit,rec=jtg)CONVREAL(x*cos(s%alfaz)-s%v*sin(s%alfaz)) 00945 case(mnem_gwu) 00946 write(unit,rec=jtg)CONVREAL(x*cos(s%alfaz)-s%gwv*sin(s%alfaz)) 00947 case(mnem_v) 00948 write(unit,rec=jtg)CONVREAL(s%u*sin(s%alfaz)+x*cos(s%alfaz)) 00949 case(mnem_gwv) 00950 write(unit,rec=jtg)CONVREAL(s%gwu*sin(s%alfaz)+x*cos(s%alfaz)) 00951 case(mnem_ue) 00952 write(unit,rec=jtg)CONVREAL(x*cos(s%alfaz)-s%ve*sin(s%alfaz)) 00953 case(mnem_ve) 00954 write(unit,rec=jtg)CONVREAL(s%ue*sin(s%alfaz)+x*cos(s%alfaz)) 00955 case(mnem_ui) 00956 write(unit,rec=jtg)CONVREAL(x*cos(s%alfaz)-s%vi*sin(s%alfaz)) 00957 case(mnem_vi) 00958 write(unit,rec=jtg)CONVREAL(s%ui*sin(s%alfaz)+x*cos(s%alfaz)) 00959 case(mnem_umean) 00960 write(unit,rec=jtg)CONVREAL(x*cos(s%alfaz)-s%vmean*sin(s%alfaz)) 00961 case(mnem_vmean) 00962 write(unit,rec=jtg)CONVREAL(s%umean*sin(s%alfaz)+x*cos(s%alfaz)) 00963 case(mnem_uwf) 00964 write(unit,rec=jtg)CONVREAL(x*cos(s%alfaz)-s%vwf*sin(s%alfaz)) 00965 case(mnem_vwf) 00966 write(unit,rec=jtg)CONVREAL(s%uwf*sin(s%alfaz)+x*cos(s%alfaz)) 00967 case(mnem_Sutot) 00968 write(unit,rec=jtg)CONVREAL((sum(s%Subg,DIM=3)+sum(s%Susg,DIM=3))*cos(s%alfaz) - (sum(s%Svbg,DIM=3)+& 00969 sum(s%Svsg,DIM=3))*sin(s%alfaz)) 00970 case(mnem_Svtot) 00971 write(unit,rec=jtg)CONVREAL((sum(s%Subg,DIM=3)+sum(s%Susg,DIM=3))*sin(s%alfaz) + (sum(s%Svbg,DIM=3)+& 00972 sum(s%Svsg,DIM=3))*cos(s%alfaz)) 00973 case(mnem_cctot) 00974 write(unit,rec=jtg)CONVREAL(sum(s%ccg,DIM=3)) 00975 case default 00976 write(unit,rec=jtg) CONVREAL(x) 00977 end select 00978 00979 end subroutine outarray_r2 00980 00981 subroutine outarray_r3(s,index,x) 00982 use spaceparams 00983 implicit none 00984 type(spacepars),intent(in) :: s 00985 integer index 00986 real*8, dimension(:,:,:), pointer :: x 00987 integer :: unit,reclen,jtg 00988 character*(dimnamelen) :: mnem 00989 real*8,parameter :: pi = 4*atan(1.0d0) 00990 00991 inquire(iolength=reclen) CONVREAL(x) 00992 call checkfile(index,unit,reclen,jtg) 00993 00994 mnem = mnemonics(outnumbers(index)) 00995 00996 !! 00997 !! Dano: need to find elegant way to multiply 3d array woth 2d alfaz 00998 ! select case(mnem) 00999 ! case(mnem_cgx) 01000 ! write(unit,rec=jtg)x*cos(s%alfaz)-s%cgy*sin(s%alfaz) 01001 ! case(mnem_cgy) 01002 ! write(unit,rec=jtg)s%cgx*sin(s%alfaz)+x*cos(s%alfaz) 01003 ! case(mnem_cx) 01004 ! write(unit,rec=jtg)x*cos(s%alfaz)-s%cy*sin(s%alfaz) 01005 ! case(mnem_cy) 01006 ! write(unit,rec=jtg)s%cx*sin(s%alfaz)+x*cos(s%alfaz) 01007 ! case(mnem_thet) 01008 ! write(unit,rec=jtg)270-((s%thet+s%alfaz)*(180/pi)) 01009 ! case(mnem_Susg) 01010 ! write(unit,rec=jtg)x*cos(s%alfaz)-s%Svsg*sin(s%alfaz) 01011 ! case(mnem_Svsg) 01012 ! write(unit,rec=jtg)s%Susg*sin(s%alfaz)+x*cos(s%alfaz) 01013 ! case(mnem_Subg) 01014 ! write(unit,rec=jtg)x*cos(s%alfaz)-s%Svbg*sin(s%alfaz) 01015 ! case(mnem_Svbg) 01016 ! write(unit,rec=jtg)s%Subg*sin(s%alfaz)+x*cos(s%alfaz) 01017 ! case default 01018 write(unit,rec=jtg) CONVREAL(x) 01019 ! end select 01020 ! wwvv to avoid warning about unused parameter s: 01021 if (s%nx .eq. -1) return 01022 end subroutine outarray_r3 01023 01024 subroutine outarray_r4(index,x) 01025 implicit none 01026 integer index 01027 real*8, dimension(:,:,:,:), pointer :: x 01028 integer :: unit,reclen,jtg 01029 01030 inquire(iolength=reclen) CONVREAL(x) 01031 call checkfile(index,unit,reclen,jtg) 01032 write(unit,rec=jtg) CONVREAL(x) 01033 end subroutine outarray_r4 01034 01035 subroutine outarray_i0(index,x) 01036 implicit none 01037 integer :: index 01038 integer,intent(in) :: x 01039 integer :: unit,reclen,jtg 01040 01041 inquire(iolength=reclen) x 01042 call checkfile(index,unit,reclen,jtg) 01043 01044 write(unit,rec=jtg) x 01045 01046 end subroutine outarray_i0 01047 01048 subroutine outarray_i1(index,x) 01049 implicit none 01050 integer index 01051 integer, dimension(:), pointer :: x 01052 integer :: unit,reclen,jtg 01053 01054 inquire(iolength=reclen) x 01055 call checkfile(index,unit,reclen,jtg) 01056 write(unit,rec=jtg) x 01057 end subroutine outarray_i1 01058 01059 subroutine outarray_i2(index,x) 01060 implicit none 01061 integer index 01062 integer, dimension(:,:), pointer :: x 01063 integer :: unit,reclen,jtg 01064 01065 inquire(iolength=reclen) x 01066 call checkfile(index,unit,reclen,jtg) 01067 write(unit,rec=jtg) x 01068 end subroutine outarray_i2 01069 01070 subroutine outarray_i3(index,x) 01071 implicit none 01072 integer index 01073 integer, dimension(:,:,:), pointer :: x 01074 integer :: unit,reclen,jtg 01075 01076 inquire(iolength=reclen) x 01077 call checkfile(index,unit,reclen,jtg) 01078 write(unit,rec=jtg) x 01079 end subroutine outarray_i3 01080 01081 subroutine outarray_i4(index,x) 01082 implicit none 01083 integer index 01084 integer, dimension(:,:,:,:), pointer :: x 01085 integer :: unit,reclen,jtg 01086 01087 inquire(iolength=reclen) x 01088 call checkfile(index,unit,reclen,jtg) 01089 write(unit,rec=jtg) x 01090 end subroutine outarray_i4 01091 01092 subroutine checkfile(index,unit,reclen,jtg) 01093 implicit none 01094 integer, intent(in) :: index,reclen 01095 integer, intent(out) :: unit,jtg 01096 logical :: lopen 01097 character(len=1000) :: filename 01098 01099 unit = indextoglobalunit(index) 01100 inquire(unit=unit, opened=lopen) 01101 if ( .not. lopen ) then 01102 filename = trim(mnemonics(outnumbers(index)))//'.dat' 01103 open(unit, file=trim(filename),form='unformatted',& 01104 access='direct',recl=reclen) 01105 endif 01106 inquire(unit=unit,nextrec=jtg) 01107 end subroutine checkfile 01108 01109 integer function indextoglobalunit(index) 01110 implicit none 01111 integer, intent(in) :: index 01112 indextoglobalunit = 100+index 01113 end function indextoglobalunit 01114 01115 integer function indextomeanunit(index) 01116 implicit none 01117 integer, intent(in) :: index 01118 indextomeanunit = 100+numvars+index 01119 end function indextomeanunit 01120 01121 integer function indextopointsunit(index) 01122 implicit none 01123 integer, intent(in) :: index 01124 indextopointsunit = 100+20*numvars+index 01125 end function indextopointsunit 01126 01127 integer function indextocrossunit(index) 01128 implicit none 01129 integer, intent(in) :: index 01130 indextocrossunit = 100+30*numvars+index 01131 end function indextocrossunit 01132 01133 integer function indextominunit(index) 01134 implicit none 01135 integer, intent(in) :: index 01136 indextominunit = 100+40*numvars+index 01137 end function indextominunit 01138 01139 integer function indextomaxunit(index) 01140 implicit none 01141 integer, intent(in) :: index 01142 indextomaxunit = 100+50*numvars+index 01143 end function indextomaxunit 01144 01145 integer function indextovarunit(index) 01146 implicit none 01147 integer, intent(in) :: index 01148 indextovarunit = 100+60*numvars+index 01149 end function indextovarunit 01150 01151 integer function indextodrifterunit(index) 01152 implicit none 01153 integer, intent(in) :: index 01154 indextodrifterunit = 700+index 01155 end function indextodrifterunit 01156 01157 end module fortoutput_module 01158 ! matching #if 0 at the start: 01159 #endif
1.7.6.1
