├── .gitignore ├── test └── src.mitgcm │ ├── cppdefs.f90 │ ├── particle_init.bin │ ├── size.h │ ├── load_depth.f90 │ ├── close_files.f90 │ ├── dump_pickup.f90 │ ├── mod_argo.f90 │ ├── read_pickup.f90 │ ├── init_parti_xyz.py │ ├── load_3d.f90 │ ├── NML.TEST_0000 │ ├── c_interp_bilinear.f90 │ ├── c_interp_trilinear.f90 │ ├── c_set_boundary.f90 │ ├── calc_parameters.f90 │ ├── allocate_vars.f90 │ ├── r_namelist.f90 │ ├── load_reflect.f90 │ ├── Makefile │ ├── c_forward_rk4.f90 │ ├── check_and_dump.f90 │ ├── load_uvw_sose_iter100.f90 │ ├── init_particles.f90 │ ├── c_gradient.f90 │ ├── load_data.f90 │ ├── global.f90 │ ├── open_files.f90 │ ├── dump_data.f90 │ ├── utils.f90 │ ├── c_find_particle_index.f90 │ ├── c_find_uvw.f90 │ ├── driver_omp.f90 │ ├── c_loop_jump.f90 │ ├── interp_tracer.f90 │ ├── NML.TEST_0000.explained │ ├── c_mixing.f90 │ ├── io.f90 │ ├── random.f90 │ └── particles.f90 ├── src ├── particle_init.bin ├── data.glider.nml ├── size.h.sose100 ├── size.h ├── load_depth.f90 ├── close_files.f90 ├── cpp_options.h ├── mod_argo.f90 ├── interp_bilinear.f90 ├── data.nml.sose ├── save_pickup.f90 ├── calc_parameters.f90 ├── data.nml ├── data.nml.dimes0010 ├── data.nml.dimes0011 ├── init_parti_xyz.py ├── read_pickup.f90 ├── interp_trilinear.f90 ├── mixing.f90 ├── get_particle_index.f90 ├── apply_boundaryCondition.f90 ├── load_reflect.f90 ├── set_file_ids.f90 ├── check_and_save.f90 ├── load_uvw_sose_iter100.f90 ├── calc_gradient.f90 ├── allocate_vars.f90 ├── load_data.f90 ├── init_particles.f90 ├── read_namelist.f90 ├── mixing_mld.f90 ├── c_filenames.f90 ├── utils.f90 ├── open_files.f90 ├── apply_jump.f90 ├── Makefile ├── rk4.f90 ├── get_argo_w.f90 ├── data.nml.explained ├── global.f90 ├── get_velocity.f90 ├── interp_tracer.f90 ├── get_glider_velocity.f90 ├── driver_omp.f90 ├── random.f90 ├── particles.f90 └── io.f90 ├── examples ├── sose_example │ └── sync_data.sh └── soccom_floats │ ├── soccom_parameters.txt │ └── run_soccom_floats.py ├── scripts ├── p_xy.py ├── init_parti_xyz.py ├── gen_simple_velocity.py ├── glue_opt_data.py └── gen_data.py ├── docs ├── Makefile └── source │ ├── argo.mode.rst │ ├── index.rst │ ├── customize_velocity.rst │ └── conf.py ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.mod 3 | -------------------------------------------------------------------------------- /test/src.mitgcm/cppdefs.f90: -------------------------------------------------------------------------------- 1 | #define saveTSG .TRUE. 2 | -------------------------------------------------------------------------------- /src/particle_init.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jinbow/Octopus/HEAD/src/particle_init.bin -------------------------------------------------------------------------------- /src/data.glider.nml: -------------------------------------------------------------------------------- 1 | &PARAMG 2 | parking_time=10, 3 | absv=0.25, 4 | surfacing_time=600, 5 | dive_depth=40, 6 | / 7 | -------------------------------------------------------------------------------- /test/src.mitgcm/particle_init.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jinbow/Octopus/HEAD/test/src.mitgcm/particle_init.bin -------------------------------------------------------------------------------- /examples/sose_example/sync_data.sh: -------------------------------------------------------------------------------- 1 | wget http://www-pord.ucsd.edu/~jinbo/not-listed/Octopus/data.tar 2 | tar xvf data.tar 3 | cd data 4 | gunzip *.gz 5 | -------------------------------------------------------------------------------- /src/size.h.sose100: -------------------------------------------------------------------------------- 1 | integer*8, parameter :: Nx=2160, Ny=320, Nz=42 2 | integer*8, parameter :: Nrecs=2191 3 | real*8, parameter :: dt_file=86400 ! 1day state 4 | -------------------------------------------------------------------------------- /test/src.mitgcm/size.h: -------------------------------------------------------------------------------- 1 | integer*8, parameter :: Nx=2160, Ny=320, Nz=42 2 | integer*8, parameter :: Nrecs=2191 3 | real*8, parameter :: dt_file=86400 ! 1day state 4 | -------------------------------------------------------------------------------- /examples/soccom_floats/soccom_parameters.txt: -------------------------------------------------------------------------------- 1 | cruise_name='P16' 2 | start_date='01/01/2016' 3 | duration=40 #in days 4 | NPP=2 #number of cases to run 5 | dt_case=365*86400 #the time interval between each case 6 | -------------------------------------------------------------------------------- /src/size.h: -------------------------------------------------------------------------------- 1 | integer*8, parameter :: Nx=1801, Ny=1024, Nz=104!llc4320 calval_california 2 | integer*8, parameter :: Nrecs=366 3 | integer*8, parameter :: Nvar2read=6 4 | real*8, parameter :: dt_file=432000 !hourly state 5 | -------------------------------------------------------------------------------- /src/load_depth.f90: -------------------------------------------------------------------------------- 1 | subroutine load_depth() 2 | use global, only: sose_depth,Nx,Ny,path2uvw 3 | implicit none 4 | open(53,file=trim(path2uvw)//'sose_depth.bin',& 5 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 6 | status='old',recl=4*Nx*Ny) 7 | read(53,rec=1) sose_depth 8 | close(53) 9 | end subroutine load_depth 10 | -------------------------------------------------------------------------------- /test/src.mitgcm/load_depth.f90: -------------------------------------------------------------------------------- 1 | subroutine load_depth() 2 | use global, only: sose_depth,Nx,Ny,path2uvw 3 | implicit none 4 | open(53,file=trim(path2uvw)//'sose_depth.bin',& 5 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 6 | status='old',recl=4*Nx*Ny) 7 | read(53,rec=1) sose_depth 8 | close(53) 9 | end subroutine load_depth 10 | -------------------------------------------------------------------------------- /src/close_files.f90: -------------------------------------------------------------------------------- 1 | subroutine close_files() 2 | use global, only: fn_ids,fn_uvwtsg_ids,fn_id_mld,NPP 3 | implicit none 4 | integer :: i 5 | ! do i =1,20 6 | ! do j=1,NPP 7 | ! close(fn_ids(i,j)) 8 | ! enddo 9 | ! enddo 10 | do i =1,6 11 | close(fn_uvwtsg_ids(i)) 12 | enddo 13 | close(fn_id_mld) 14 | 15 | end subroutine close_files 16 | -------------------------------------------------------------------------------- /test/src.mitgcm/close_files.f90: -------------------------------------------------------------------------------- 1 | subroutine close_files() 2 | use global, only: fn_ids,fn_uvwtsg_ids,fn_id_mld,NPP 3 | implicit none 4 | integer :: i 5 | ! do i =1,20 6 | ! do j=1,NPP 7 | ! close(fn_ids(i,j)) 8 | ! enddo 9 | ! enddo 10 | do i =1,6 11 | close(fn_uvwtsg_ids(i)) 12 | enddo 13 | close(fn_id_mld) 14 | 15 | end subroutine close_files 16 | -------------------------------------------------------------------------------- /examples/soccom_floats/run_soccom_floats.py: -------------------------------------------------------------------------------- 1 | """ 2 | auto run soccom float simulation 3 | 4 | Jinbo Wang 5 | """ 6 | 7 | import numpy as np 8 | import os,sys 9 | 10 | if __name__=='__main__': 11 | 12 | try: 13 | os.popen('cp %s parameter.py'%(sys.argv[1]) 14 | except: 15 | sys.exit('use python run_soccom_floats.py your_parameter_file.txt') 16 | 17 | import parameter 18 | 19 | 20 | -------------------------------------------------------------------------------- /src/cpp_options.h: -------------------------------------------------------------------------------- 1 | #define saveTSG 2 | #undef isArgo 3 | #define isGlider 4 | #undef saveArgoProfile 5 | #undef reflective_continent 6 | #undef use_Laplacian_diffusion 7 | #undef use_mixedlayer_shuffle 8 | #undef saveGradient 9 | #undef reflective_meridional_boundary 10 | #undef jump_looping 11 | #undef periodic_x 12 | #undef monitoring 13 | #undef one_file_per_step 14 | #undef stationary_velocity 15 | #define barrier_lon 16 | #undef barrier_lat 17 | -------------------------------------------------------------------------------- /test/src.mitgcm/dump_pickup.f90: -------------------------------------------------------------------------------- 1 | subroutine dump_pickup() 2 | use global, only: casename,tt,DumpClock,tsg,xyz 3 | implicit none 4 | character(len=64) :: fn 5 | write(fn,"(I10.10)") int(tt/DumpClock)+1 6 | print*, fn 7 | open(0,file=trim(casename)//'.pickup.'//trim(fn)//'.data',form='unformatted',& 8 | access='stream',convert='BIG_ENDIAN',status='replace') 9 | write(0) xyz,tsg,tt 10 | close(0) 11 | end subroutine dump_pickup 12 | -------------------------------------------------------------------------------- /src/mod_argo.f90: -------------------------------------------------------------------------------- 1 | MODULE particles 2 | USE global 3 | ! define the class for particles 4 | TYPE argo 5 | REAL(kind=rc_kind) :: x,y,z,tc, 6 | END TYPE particle 7 | 8 | TYPE (particle), DIMENSION(:), ALLOCATABLE :: parti 9 | REAL(kind=rc_kind) :: dz,swap1,swap2,swap3 10 | INTEGER,ALLOCATABLE :: file_id(:) 11 | INTEGER :: NPR_eachfile 12 | CHARACTER(len=3) :: file_id_char 13 | 14 | PRIVATE :: NPR_eachfile, file_id_char, dz, swap1, swap2, swap3, 15 | file_id 16 | PUBLIC :: parti 17 | 18 | CONTAINS 19 | -------------------------------------------------------------------------------- /test/src.mitgcm/mod_argo.f90: -------------------------------------------------------------------------------- 1 | MODULE particles 2 | USE global 3 | ! define the class for particles 4 | TYPE argo 5 | REAL(kind=rc_kind) :: x,y,z,tc, 6 | END TYPE particle 7 | 8 | TYPE (particle), DIMENSION(:), ALLOCATABLE :: parti 9 | REAL(kind=rc_kind) :: dz,swap1,swap2,swap3 10 | INTEGER,ALLOCATABLE :: file_id(:) 11 | INTEGER :: NPR_eachfile 12 | CHARACTER(len=3) :: file_id_char 13 | 14 | PRIVATE :: NPR_eachfile, file_id_char, dz, swap1, swap2, swap3, 15 | file_id 16 | PUBLIC :: parti 17 | 18 | CONTAINS 19 | -------------------------------------------------------------------------------- /test/src.mitgcm/read_pickup.f90: -------------------------------------------------------------------------------- 1 | subroutine read_pickup() 2 | use global, only: casename,xyz,tsg,tt,pickup 3 | implicit none 4 | character(len=128) :: fn 5 | 6 | write(fn,"(I10.10)") int(pickup) 7 | fn=trim(casename)//'.pickup.'//trim(fn)//'.data' 8 | open(10,file=trim(fn),form='unformatted',& 9 | access='stream',convert='BIG_ENDIAN',status='old') 10 | print*, "=========================================" 11 | print*, "pickup data from "//fn 12 | 13 | read(10) xyz,tsg,tt 14 | 15 | close(10) 16 | 17 | end subroutine read_pickup 18 | -------------------------------------------------------------------------------- /test/src.mitgcm/init_parti_xyz.py: -------------------------------------------------------------------------------- 1 | from numpy import * 2 | import sys 3 | #to run this script in commandline: 4 | # python init_parti_xyz.py 5 | def case_test(): 6 | npts=100 7 | xyz=zeros((npts,3)) 8 | xyz[:,0]= linspace(1500,1600,npts) # x index 100 points 9 | xyz[:,1]= 110 #constant y 10 | xyz[:,2]=20 # at k=20 level, z level will be overwritten if the target_density in the namelist is larger than 0. 11 | 12 | xyz.T.astype('>f8').tofile('particle_init.bin') #the saving sequence should be x[:], y[:], z[:], not [x1,y1,z1],[x2,y2,z2]... 13 | 14 | return 15 | 16 | 17 | if __name__=='__main__': 18 | case_test() 19 | -------------------------------------------------------------------------------- /scripts/p_xy.py: -------------------------------------------------------------------------------- 1 | """ Plot some trajectories 2 | Jinbo Wang 3 | 4 | Scripps Institution of Oceanography 5 | August 26, 2015 """ 6 | 7 | 8 | from numpy import * 9 | from pylab import * 10 | 11 | fn='DIMES_0004_0033.XYZ.0000000166.0000002161.data' #put a glued XYZ data filename 12 | npts=35000 #specify particle numbers 13 | opt=fromfile(fn,'>f4').reshape(-1,3,npts) 14 | 15 | print "data has %i records"%(opt.shape[0]) 16 | 17 | #plot some trajectories 18 | x,y=opt[:,0,:10],opt[:,1,:10] #this is in model grid index coordinate, convert to lat-lon using x=x/6.0;y=y/6.0-77.875 19 | plot(x,y,'-') 20 | xlabel('x') 21 | ylabel('y') 22 | show() 23 | -------------------------------------------------------------------------------- /scripts/init_parti_xyz.py: -------------------------------------------------------------------------------- 1 | """Calculate the lookup table for k to z conversion 2 | Jinbo Wang 3 | 4 | Scripps Institution of Oceanography 5 | August 26, 2015 """ 6 | 7 | from numpy import * 8 | import sys 9 | 10 | def test(): 11 | center=r_[10,10,25].reshape(-1,3) 12 | delta=r_[1,1,0.1].reshape(-1,3) 13 | xyz = random.random((npts,3)) - 0.5 14 | xyz = xyz*2*delta+center 15 | fn = 'particle_initial_xyz.bin' 16 | xyz.T.astype('>f8').tofile(fn) 17 | print("write particle initial positions to file "+fn) 18 | return 19 | 20 | 21 | if __name__=='__main__': 22 | npts=21 # the number of particles 23 | test() 24 | -------------------------------------------------------------------------------- /test/src.mitgcm/load_3d.f90: -------------------------------------------------------------------------------- 1 | 2 | subroutine load_3d(fn_id,irec,dout) 3 | use global, only : Nx,Ny,Nz,Nrecs 4 | implicit none 5 | INTEGER*8, intent(in) :: irec,fn_id 6 | real*4, dimension(-2:Nx+1,0:Ny-1,-1:Nz), intent(out) :: dout 7 | integer*8 :: i,k 8 | 9 | i=mod(irec,Nrecs) 10 | if (i .eq. 0) then 11 | i=Nrecs 12 | endif 13 | 14 | i=(i-1)*Nz+1 15 | !$OMP PARALLEL DO PRIVATE(k) 16 | do k=0,Nz-1 17 | read(fn_id,rec=i+k) dout(0:Nx-1,:,k) 18 | dout(Nx:Nx+1,:,k)=dout(0:1,:,k) 19 | dout(-2:-1,:,k)=dout(Nx-2:Nx-1,:,k) 20 | enddo 21 | !$OMP END PARALLEL DO 22 | 23 | 24 | end subroutine load_3d 25 | -------------------------------------------------------------------------------- /src/interp_bilinear.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE interp_bilinear(di,dj,var,velp) 2 | !== give 4 corner points of a square, interpolate point values inside 3 | !== di is the distance of the particle to the left face 4 | !== dj is the distance of the particle to the southern face 5 | 6 | IMPLICIT NONE 7 | REAL*8, INTENT(in) :: di,dj 8 | REAL*4, INTENT(in), DIMENSION( 2, 2 ) :: var 9 | REAL*8, INTENT(out) :: velp 10 | REAL*8 :: i1,i4 11 | 12 | ! calcuate the bilinear interpolation 13 | i1 = (var(2,1) - var(1,1))*di + var(1,1) 14 | i4 = (var(2,2) - var(1,2))*di + var(1,2) 15 | velp = (i4 - i1)*dj + i1 16 | 17 | END SUBROUTINE interp_bilinear 18 | -------------------------------------------------------------------------------- /test/src.mitgcm/NML.TEST_0000: -------------------------------------------------------------------------------- 1 | &PARAM 2 | casename='TEST_0000', 3 | path2uvw='../data/', 4 | fn_UVEL='UVEL.0000000100.data', 5 | fn_VVEL='VVEL.0000000100.data', 6 | fn_WVEL='WVEL.0000000100.data', 7 | fn_THETA='', 8 | fn_SALT='', 9 | fn_GAMMA='', 10 | fn_PHIHYD='', 11 | fn_parti_init='particle_init.bin', 12 | target_density=-1, 13 | vel_stationary=.False., 14 | Npts=100, 15 | dt_reinit=-1, 16 | dt_mld=432000., 17 | dt=432000, 18 | tstart=0., 19 | tend=86400., 20 | NPP=1, 21 | dt_case=864000, 22 | pickup=0., 23 | dumpFreq=86400., 24 | diagFreq=864000., 25 | pickupFreq=7776000., 26 | saveTSG=.False., 27 | useMLD=.False., 28 | useKh=.False., 29 | Khdiff=0, 30 | Kvdiff=0, 31 | / 32 | -------------------------------------------------------------------------------- /test/src.mitgcm/c_interp_bilinear.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE interp_bilinear(di,dj,var,velp) 2 | !== give 4 corner points of a square, interpolate point values inside 3 | !== di is the distance of the particle to the left face 4 | !== dj is the distance of the particle to the southern face 5 | IMPLICIT NONE 6 | REAL*8, INTENT(in) :: di,dj 7 | REAL*4, INTENT(in), DIMENSION( 2, 2 ) :: var 8 | REAL*8, INTENT(out) :: velp 9 | REAL*8 :: i1,i4 10 | 11 | ! calcuate the bilinear interpolation 12 | i1 = (var(2,1) - var(1,1))*di + var(1,1) 13 | i4 = (var(2,2) - var(1,2))*di + var(1,2) 14 | velp = (i4 - i1)*dj + i1 15 | 16 | END SUBROUTINE interp_bilinear 17 | -------------------------------------------------------------------------------- /docs/Makefile: -------------------------------------------------------------------------------- 1 | # Minimal makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line. 5 | SPHINXOPTS = 6 | SPHINXBUILD = sphinx-build 7 | SPHINXPROJ = Octopus 8 | SOURCEDIR = source 9 | BUILDDIR = build 10 | 11 | # Put it first so that "make" without argument is like "make help". 12 | help: 13 | @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 14 | 15 | .PHONY: help Makefile 16 | 17 | # Catch-all target: route all unknown targets to Sphinx using the new 18 | # "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). 19 | %: Makefile 20 | @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) -------------------------------------------------------------------------------- /docs/source/argo.mode.rst: -------------------------------------------------------------------------------- 1 | Argo simulation 2 | ######################## 3 | 4 | Steps to run: 5 | =============== 6 | 7 | Most of the steps are the same as for Lagrangian particle simulation with few exceptions. 8 | 9 | 1. Make sure **isArgo** is defined in **cpp_options.h**: **#define isArgo** 10 | 1. Use *"make argo"* to compile the code. 11 | 1. You will get a executable **O.argo** after successfully compiling the code. 12 | 1. Run the code using 13 | 14 | >./O.argo 15 | 16 | If you run into the following error message: 17 | Fortran runtime error: File '../data/DXG.data, DYG.data, or DRF.data' does not exist 18 | You will need to go into the data directory and change the dxg.bin, dyg.bin, drf.bin to DXG.data, DYG.data, DRF.data . 19 | -------------------------------------------------------------------------------- /src/data.nml.sose: -------------------------------------------------------------------------------- 1 | &PARAM 2 | pickup=0, 3 | casename='TEST_0000', 4 | path2uvw='../data/', 5 | path2grid='../data/', 6 | output_dir='../output/', 7 | fn_UVEL='UVEL.0000000100.data', 8 | fn_VVEL='VVEL.0000000100.data', 9 | fn_WVEL='WVEL.0000000100.data', 10 | fn_THETA='THETA.0000000100.data', 11 | fn_SALT='SALT.0000000100.data', 12 | fn_GAMMA='GAMMA.0000000100.data', 13 | fn_MLD='MLD.0000000100.data', 14 | fn_PHIHYD='', 15 | fn_parti_init='particle_init.bin', 16 | target_density=-1, 17 | vel_stationary=.False., 18 | Npts=100, 19 | dt_reinit=-1, 20 | dt_mld=120., 21 | dt=60., 22 | tstart=60., 23 | tend=300, 24 | NPP=1, 25 | dt_case=864000, 26 | saveFreq=60, 27 | diagFreq=864000., 28 | pickupFreq=120, 29 | Khdiff=25.0, 30 | Kvdiff=1e-5, 31 | DumpClock=60, 32 | / 33 | -------------------------------------------------------------------------------- /src/save_pickup.f90: -------------------------------------------------------------------------------- 1 | subroutine save_pickup() 2 | #include "cpp_options.h" 3 | use global, only: casename,tt,DumpClock,tsg,xyz,iswitch,rec_num,output_dir,marker 4 | implicit none 5 | character(len=64) :: fn 6 | 7 | write(fn,"(I10.10)") int(tt/DumpClock)+1 8 | open(0,file=trim(output_dir)//trim(casename)//'.pickup.'//trim(fn)//'.data',form='unformatted',& 9 | access='stream',convert='BIG_ENDIAN',status='replace') 10 | write(0) xyz,tsg,tt,iswitch,rec_num,marker 11 | 12 | #ifdef monitoring 13 | print*, "save data from pickup file ",fn 14 | print*, 'data saved marker, rec_num iswitch,tt',marker,rec_num,iswitch,tt 15 | print*, 'in the pickup file, (min,max xyz), (min max tsg), ', xyz(1,:,1) 16 | #endif 17 | 18 | close(0) 19 | end subroutine save_pickup 20 | -------------------------------------------------------------------------------- /src/calc_parameters.f90: -------------------------------------------------------------------------------- 1 | subroutine calc_parameters() 2 | use global, only: fn_uvwtsg_ids,nrecs,dt_file,t_amend,& 3 | tend,tend_file, Kvdiff,Khdiff,dt,fn_ids,& 4 | khdt2,kvdt2,output_dir,fn_id_mld,NPP,& 5 | pickup,DumpClock,tt,tstart,rec_num 6 | implicit none 7 | integer*8 :: i,j 8 | 9 | tt=tstart 10 | rec_num = floor(tt/dt_file)+1 11 | print*, 'record number in calc_par...',rec_num,tt,tstart 12 | 13 | kvdt2 = sqrt(2*Kvdiff*dt) 14 | khdt2 = sqrt(2*Khdiff*dt) 15 | !time stepping 16 | tend_file=nrecs*dt_file 17 | if (tend<=0) then 18 | tend = nrecs*dt_file 19 | endif 20 | t_amend=real(dt/dt_file/2d0,8) 21 | 22 | call set_file_ids() 23 | 24 | end subroutine calc_parameters 25 | -------------------------------------------------------------------------------- /src/data.nml: -------------------------------------------------------------------------------- 1 | &PARAM 2 | pickup=0, 3 | casename='test', 4 | path2uvw='/data/SOSE/SOSE/SO12/RUN_BLING_Dec2017/DATA/', 5 | path2grid='/home/jiw097/sose.grid/', 6 | output_dir='test/', 7 | fn_UVEL='UVEL_ForEmmaV0.bin', 8 | fn_VVEL='VVEL_ForEmmaV0.bin', 9 | fn_WVEL='WVEL_ForEmmaV0.bin', 10 | fn_THETA='THETA_ForEmmaV0.bin', 11 | fn_SALT='SALT_ForEmmaV0.bin', 12 | fn_GAMMA='', 13 | fn_MLD='MLD_ForEmmaV0.bin', 14 | fn_PHIHYD='', 15 | FnPartiInit='particle_init.bin', 16 | target_density=-1, 17 | Npts=20, 18 | dt_reinit=-1, 19 | dt_mld=12000., 20 | dt=21600., 21 | tstart=0., 22 | tend=31104000, 23 | NPP=1, 24 | dt_case=86400, 25 | saveFreq=86400, 26 | diagFreq=864000, 27 | pickupFreq=86400000, 28 | Khdiff=5, 29 | Kvdiff=1e-5, 30 | DumpClock=3600, 31 | barrier_east=1000, 32 | barrier_west=100, 33 | barrier_north=400, 34 | barrier_south=10, 35 | / 36 | -------------------------------------------------------------------------------- /src/data.nml.dimes0010: -------------------------------------------------------------------------------- 1 | &PARAM 2 | pickup=0, 3 | casename='DIMES_0010', 4 | path2uvw='../data_in/sose100/', 5 | path2grid='../data_in/sose100/', 6 | output_dir='../data_out/', 7 | fn_UVEL='UVEL.0000000100.data', 8 | fn_VVEL='VVEL.0000000100.data', 9 | fn_WVEL='WVEL.0000000100.data', 10 | fn_THETA='THETA.0000000100.data', 11 | fn_SALT='SALT.0000000100.data', 12 | fn_GAMMA='GAMMA.0000000100.data', 13 | fn_MLD='MLD.0000000100.data', 14 | fn_PHIHYD='', 15 | fn_parti_init='particle_init_DIMES_0010_1E6.bin', 16 | target_density=27.9, 17 | vel_stationary=.False., 18 | Npts=1000000, 19 | dt_reinit=-1, 20 | dt_mld=432000., 21 | dt=43200., 22 | tstart=2592000., 23 | tend=189216000., 24 | NPP=12, 25 | dt_case=432000, 26 | saveFreq=86400, 27 | diagFreq=864000., 28 | pickupFreq=8640000, 29 | Khdiff=50.0, 30 | Kvdiff=1e-5, 31 | DumpClock=60, 32 | / 33 | -------------------------------------------------------------------------------- /src/data.nml.dimes0011: -------------------------------------------------------------------------------- 1 | &PARAM 2 | pickup=0, 3 | casename='DIMES_0011', 4 | path2uvw='../data_in/sose100/', 5 | path2grid='../data_in/sose100/', 6 | output_dir='../data_out/', 7 | fn_UVEL='UVEL.0000000100.data', 8 | fn_VVEL='VVEL.0000000100.data', 9 | fn_WVEL='WVEL.0000000100.data', 10 | fn_THETA='THETA.0000000100.data', 11 | fn_SALT='SALT.0000000100.data', 12 | fn_GAMMA='GAMMA.0000000100.data', 13 | fn_MLD='MLD.0000000100.data', 14 | fn_PHIHYD='', 15 | fn_parti_init='particle_init_DIMES_0010_1E6.bin', 16 | target_density=27.9, 17 | vel_stationary=.False., 18 | Npts=1000000, 19 | dt_reinit=-1, 20 | dt_mld=432000., 21 | dt=43200., 22 | tstart=2592000., 23 | tend=189216000., 24 | NPP=12, 25 | dt_case=432000, 26 | saveFreq=86400, 27 | diagFreq=864000., 28 | pickupFreq=8640000, 29 | Khdiff=50.0, 30 | Kvdiff=1e-5, 31 | DumpClock=60, 32 | / 33 | -------------------------------------------------------------------------------- /src/init_parti_xyz.py: -------------------------------------------------------------------------------- 1 | from numpy import * 2 | import sys 3 | #to run this script in commandline: 4 | # python init_parti_xyz.py 5 | 6 | def glider_target(npts=2): 7 | 8 | xyz=zeros((npts,2)) 9 | xy[:,0]=400 10 | return 11 | 12 | 13 | def case_test(npts=2): 14 | xyz=zeros((npts,3)) 15 | xyz[:,0]= linspace(5,6,npts) # x index 100 points 16 | xyz[:,1]= 15 #constant y 17 | xyz[:,2]=2 # at k=20 level, z level will be overwritten if the target_density in the namelist is larger than 0. 18 | 19 | xyz[:,0] = 1000.0 20 | xyz[:,1] = linspace(100,1801,npts) 21 | xyz[:,2] = 0 22 | 23 | xyz.T.astype('>f8').tofile('particle_init.bin') #the saving sequence should be x[:], y[:], z[:], not [x1,y1,z1],[x2,y2,z2]... 24 | 25 | return 26 | 27 | 28 | if __name__=='__main__': 29 | case_test(npts=20) 30 | -------------------------------------------------------------------------------- /src/read_pickup.f90: -------------------------------------------------------------------------------- 1 | subroutine read_pickup() 2 | #include "cpp_options.h" 3 | use global, only: casename,xyz,tsg,tt,pickup,rec_num,iswitch,output_dir,marker 4 | implicit none 5 | character(len=128) :: fn 6 | 7 | write(fn,"(I10.10)") int(pickup) 8 | fn=trim(output_dir)//trim(casename)//'.pickup.'//trim(fn)//'.data' 9 | open(10,file=trim(fn),form='unformatted',& 10 | access='stream',convert='BIG_ENDIAN',status='old') 11 | 12 | 13 | read(10) xyz,tsg,tt,iswitch,rec_num,marker 14 | 15 | #ifdef monitoring 16 | print*, "=========================================" 17 | print*, "pickup data from "//fn 18 | print*, 'data in pickup file marker, rec_num iswitch,tt',marker,rec_num,iswitch,tt 19 | print*, 'in the pickup file, (min,max xyz), (min max tsg), ', xyz(1,:,1) 20 | #endif 21 | 22 | close(10) 23 | 24 | end subroutine read_pickup 25 | -------------------------------------------------------------------------------- /src/interp_trilinear.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE interp_trilinear(di,dj,dk,var,velp) 2 | !== give 8 corner points of a cube, interpolate point values inside 3 | !of the cube var(i,j,k) 4 | !== di is the distance of the particle to the left face 5 | !== dj is the distance of the particle to the southern face 6 | !== dk is the distance of the particle to the bottom face 7 | IMPLICIT NONE 8 | REAL*8, INTENT(in) :: di,dj,dk 9 | REAL*4, INTENT(in), DIMENSION( 2, 2 , 2 ) :: var 10 | REAL*8, INTENT(out) :: velp 11 | REAL*8 :: i1,i2,i3,i4,j1,j2 12 | 13 | ! calcuate the Trilinear interpolation 14 | i1 = (var(2,1, 1) - var(1,1, 1))*di + var(1,1, 1) 15 | i2 = (var(2,1, 2) - var(1,1,2))*di + var(1,1, 2) 16 | i3 = (var(2,2,2) - var(1,2,2))*di +var(1,2,2) 17 | i4 = (var(2,2,1) - var(1,2,1))*di + var(1,2,1) 18 | 19 | j1 = (i3 - i2)*dj + i2 20 | j2 = (i4 - i1)*dj + i1 21 | 22 | 23 | velp = (j1 - j2) * dk + j2 24 | 25 | END SUBROUTINE interp_trilinear 26 | -------------------------------------------------------------------------------- /test/src.mitgcm/c_interp_trilinear.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE interp_trilinear(di,dj,dk,var,velp) 2 | !== give 8 corner points of a cube, interpolate point values inside 3 | !of the cube var(i,j,k) 4 | !== di is the distance of the particle to the left face 5 | !== dj is the distance of the particle to the southern face 6 | !== dk is the distance of the particle to the bottom face 7 | IMPLICIT NONE 8 | REAL*8, INTENT(in) :: di,dj,dk 9 | REAL*4, INTENT(in), DIMENSION( 2, 2 , 2 ) :: var 10 | REAL*8, INTENT(out) :: velp 11 | REAL*8 :: i1,i2,i3,i4,j1,j2 12 | 13 | ! calcuate the Trilinear interpolation 14 | i1 = (var(2,1, 1) - var(1,1, 1))*di + var(1,1, 1) 15 | i2 = (var(2,1, 2) - var(1,1,2))*di + var(1,1, 2) 16 | i3 = (var(2,2,2) - var(1,2,2))*di +var(1,2,2) 17 | i4 = (var(2,2,1) - var(1,2,1))*di + var(1,2,1) 18 | 19 | j1 = (i3 - i2)*dj + i2 20 | j2 = (i4 - i1)*dj + i1 21 | 22 | 23 | velp = (j1 - j2) * dk + j2 24 | 25 | END SUBROUTINE interp_trilinear 26 | -------------------------------------------------------------------------------- /src/mixing.f90: -------------------------------------------------------------------------------- 1 | subroutine apply_Laplacian_diffusion(IPP) 2 | #include "cpp_options.h" 3 | 4 | use global, only: Npts,hFacC,xyz,z2k,k2z,Nx,Ny,dt_mld,tt,mld,& 5 | parti_mld,kvdt2,khdt2,dxg_r,dyg_r,drf_r,pi2f 6 | use random, only: random_normal 7 | implicit none 8 | integer*8 :: i 9 | integer*8 :: ip,jp,kp 10 | integer*8, intent(in) :: IPP 11 | 12 | call random_seed(put=int(pi2f(1:30,1),8)) 13 | 14 | !$OMP PARALLEL DO PRIVATE(i,ip,jp) 15 | do i =1,Npts 16 | ip=floor(mod(xyz(i,1,IPP),real(Nx-1))) 17 | jp=floor(xyz(i,2,IPP)) 18 | kp=floor(xyz(i,3,IPP)) 19 | !horizontal mixing 20 | xyz(i,1,IPP) = xyz(i,1,IPP)+random_normal()*khdt2*dxg_r(ip,jp) 21 | xyz(i,2,IPP) = xyz(i,2,IPP)+random_normal()*khdt2*dyg_r(ip,jp) 22 | !vertical mixing 23 | xyz(i,3,IPP) = xyz(i,3,IPP)+random_normal()*kvdt2*drf_r(kp) 24 | enddo 25 | !$OMP END PARALLEL DO 26 | end subroutine apply_Laplacian_diffusion 27 | 28 | -------------------------------------------------------------------------------- /test/src.mitgcm/c_set_boundary.f90: -------------------------------------------------------------------------------- 1 | subroutine set_boundary(IPP) 2 | use global, only:Nz,Npts,xyz,pi2f,pj2f,& 3 | pk2f,hFacC,reflect_x,reflect_y 4 | implicit none 5 | integer*8 :: ip 6 | integer*8, intent(in) :: IPP 7 | 8 | 9 | !$OMP PARALLEL DO PRIVATE(ip) SCHEDULE(dynamic) 10 | do ip =1,Npts 11 | !print*, ip, xyz(ip,:,IPP) 12 | if (xyz(ip,3,IPP)<0) then 13 | xyz(ip,3,IPP)=-xyz(ip,3,IPP) 14 | endif 15 | 16 | if (xyz(ip,3,IPP)>Nz-1) then 17 | xyz(ip,3,IPP)=real(Nz-2d0,8) 18 | endif 19 | 20 | call find_index(ip,IPP) 21 | !reflective boundary condition 22 | if (hFacC(pi2f(ip,IPP),pj2f(ip,IPP),pk2f(ip,IPP))<1e-5) then 23 | xyz(ip,1,IPP)=reflect_x(pi2f(ip,IPP),pj2f(ip,IPP),pk2f(ip,IPP)) !semi-reflective boundary 24 | xyz(ip,2,IPP)=reflect_y(pi2f(ip,IPP),pj2f(ip,IPP),pk2f(ip,IPP)) !semi-reflective boundary 25 | endif 26 | 27 | 28 | enddo 29 | !$OMP END PARALLEL DO 30 | 31 | end subroutine set_boundary 32 | -------------------------------------------------------------------------------- /src/get_particle_index.f90: -------------------------------------------------------------------------------- 1 | subroutine find_index(ip,IPP) 2 | !find particle index for C-grid variable and their distance to grid faces 3 | use global 4 | integer*8, intent(in) :: ip,IPP 5 | real*8 :: x 6 | 7 | x=mod(xyz(ip,1,IPP),real(Nx-1,8)) 8 | 9 | xyz(ip,3,IPP) = min(abs(xyz(ip,3,IPP)),real(Nz-1,8)) 10 | xyz(ip,2,IPP) = min(abs(xyz(ip,2,IPP)),real(Ny-1,8)) 11 | 12 | pi2f(ip,IPP)=floor(x) 13 | pj2f(ip,IPP)=floor(xyz(ip,2,IPP)) 14 | pk2f(ip,IPP)=floor(xyz(ip,3,IPP)) 15 | ! pi2c(ip)=floor(xyz(ip,1)-0.5d0) 16 | pi2c(ip,IPP)=floor(x-0.5d0) 17 | pj2c(ip,IPP)=floor(xyz(ip,2,IPP)-0.5d0) 18 | pk2c(ip,IPP)=floor(xyz(ip,3,IPP)-0.5d0) 19 | 20 | ! dif(ip) = xyz(ip,1)-pi2f(ip) 21 | dif(ip,IPP) = x-pi2f(ip,IPP) 22 | djf(ip,IPP) = xyz(ip,2,IPP)-pj2f(ip,IPP) 23 | dkf(ip,IPP) = xyz(ip,3,IPP)-pk2f(ip,IPP) 24 | 25 | dic(ip,IPP) = x-pi2c(ip,IPP)-0.5 26 | djc(ip,IPP) = xyz(ip,2,IPP)-pj2c(ip,IPP)-0.5d0 27 | dkc(ip,IPP) = xyz(ip,3,IPP)-pk2c(ip,IPP)-0.5d0 28 | 29 | end subroutine find_index 30 | -------------------------------------------------------------------------------- /test/src.mitgcm/calc_parameters.f90: -------------------------------------------------------------------------------- 1 | subroutine calc_parameters() 2 | use global, only: fn_uvwtsg_ids,nrecs,dt_file,t_amend,& 3 | tend,tend_file, Kvdiff,Khdiff,dt,fn_ids,& 4 | khdt2,kvdt2,output_dir,fn_id_mld,NPP,& 5 | pickup,DumpClock,tt,tstart,rec_num 6 | implicit none 7 | integer*8 :: i,j 8 | 9 | if (pickup>0) then 10 | tt=(pickup-1)*DumpClock 11 | rec_num = floor(tt/dt_file)+1 12 | else 13 | tt=tstart 14 | rec_num = floor(tt/dt_file)+1 15 | endif 16 | kvdt2 = sqrt(2*Kvdiff*dt) 17 | khdt2 = sqrt(2*Khdiff*dt) 18 | !time stepping 19 | tend_file=nrecs*dt_file 20 | if (tend<=0) then 21 | tend = nrecs*dt_file 22 | endif 23 | t_amend=real(dt/dt_file/2d0,8) 24 | 25 | ! file ids 26 | do i=0,11 27 | do j=0,NPP-1 28 | fn_ids(i+1,j+1) = 1000+j*12+i 29 | enddo 30 | enddo 31 | fn_uvwtsg_ids = (/2001,2002,2003,2004,2005,2006,2007/) 32 | fn_id_mld=3000 33 | 34 | call system('mkdir -p '//trim(output_dir)) 35 | 36 | end subroutine calc_parameters 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Jinbo Wang 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /src/apply_boundaryCondition.f90: -------------------------------------------------------------------------------- 1 | subroutine set_boundary(IPP) 2 | #include "cpp_options.h" 3 | 4 | use global 5 | implicit none 6 | integer*8 :: ip 7 | integer*8, intent(in) :: IPP 8 | 9 | 10 | !$OMP PARALLEL DO PRIVATE(ip) SCHEDULE(dynamic) 11 | do ip =1,Npts 12 | !print*, ip, xyz(ip,:,IPP) 13 | !if (xyz(ip,3,IPP)<0) then 14 | ! print*, ip,IPP,xyz(ip,3,IPP) 15 | !endif 16 | 17 | !xyz(ip,3,IPP) = min(abs(xyz(ip,3,IPP)),real(Nz-1,8)) 18 | !xyz(ip,2,IPP) = sign(xyz(ip,2,IPP),1e0) 19 | !xyz(ip,2,IPP) = min(xyz(ip,2,IPP),real(Ny-1,8)) 20 | 21 | call find_index(ip,IPP) 22 | 23 | !reflective boundary condition 24 | 25 | #ifdef reflective_continent 26 | if (hFacC(pi2f(ip,IPP),pj2f(ip,IPP),pk2f(ip,IPP))<1e-5) then 27 | xyz(ip,1,IPP)=xyz(ip,1,IPP)+reflect_x(pi2f(ip,IPP),pj2f(ip,IPP),pk2f(ip,IPP)) !semi-reflective boundary 28 | xyz(ip,2,IPP)=xyz(ip,2,IPP)+reflect_y(pi2f(ip,IPP),pj2f(ip,IPP),pk2f(ip,IPP)) !semi-reflective boundary 29 | endif 30 | #endif 31 | 32 | 33 | enddo 34 | !$OMP END PARALLEL DO 35 | 36 | end subroutine set_boundary 37 | -------------------------------------------------------------------------------- /test/src.mitgcm/allocate_vars.f90: -------------------------------------------------------------------------------- 1 | subroutine allocate_parti() 2 | 3 | use global, only :xyz, xyz0, uvwp, dxyz_fac, tsg,& 4 | pi2f,pj2f,pk2f,pi2c,pj2c,pk2c,& 5 | dif, djf, dkf, dic, djc, dkc, parti_mld,& 6 | NPP,Npts,fn_ids,grad 7 | print*, "----------------------------------------------" 8 | print*, "start allocation of variables ......" 9 | 10 | 11 | ALLOCATE ( xyz(Npts,3,NPP), & 12 | xyz0(Npts,3,NPP), & 13 | uvwp(Npts,3,NPP), & 14 | dxyz_fac(Npts,3,NPP), & 15 | grad(Npts,4,NPP), & 16 | tsg(Npts,4,NPP) ) 17 | 18 | ALLOCATE ( pi2f(Npts,NPP),& 19 | pj2f(Npts,NPP),& 20 | pk2f(Npts,NPP),& 21 | pi2c(Npts,NPP),& 22 | pj2c(Npts,NPP),& 23 | pk2c(Npts,NPP),& 24 | dif(Npts,NPP), & 25 | djf(Npts,NPP), & 26 | dkf(Npts,NPP), & 27 | dic(Npts,NPP), & 28 | djc(Npts,NPP), & 29 | dkc(Npts,NPP), & 30 | parti_mld(Npts,NPP) ) 31 | 32 | ALLOCATE ( fn_ids(20,NPP) ) 33 | 34 | print*, "end allocation of variables ......" 35 | 36 | end subroutine allocate_parti 37 | -------------------------------------------------------------------------------- /test/src.mitgcm/r_namelist.f90: -------------------------------------------------------------------------------- 1 | subroutine read_namelist() 2 | !========================================= 3 | ! read configuration file 4 | use global, only : casename,path2uvw,fn_UVEL,fn_VVEL,& 5 | fn_WVEL,dt,dt_reinit,tend,dt_case,fn_THETA,fn_SALT,& 6 | fn_GAMMA,dt_mld,pickupFreq,pickup,dumpFreq,diagFreq,tstart,fn_parti_init,& 7 | target_density,useMLD,useKh,saveTSG,vel_stationary,Khdiff,Kvdiff,NPP,Npts,output_dir,& 8 | fn_PHIHYD 9 | implicit none 10 | ! integer*8, intent(in) :: inml 11 | ! character*32 :: fn 12 | 13 | namelist /PARAM/ casename,path2uvw,fn_UVEL,fn_VVEL,& 14 | fn_WVEL,dt,tend,fn_THETA,fn_SALT,& 15 | fn_GAMMA,pickup,pickupFreq,dumpFreq,diagFreq,tstart,fn_parti_init,& 16 | target_density,dt_reinit,dt_mld,dt_case,useMLD,saveTSG,vel_stationary,& 17 | useKh,Khdiff,Kvdiff,NPP,Npts,output_dir,fn_PHIHYD 18 | 19 | read (*,NML=PARAM) 20 | 21 | !from the namelist file 22 | ! write(fn,"(I4.4)") inml 23 | ! print*, 'NML.DP_'//fn 24 | ! OPEN (UNIT=1, FILE=trim('NML.DP_'//fn)) 25 | ! OPEN (UNIT=212, FILE='data.nml') 26 | ! read (212,NML=PARAM) !from the namelist file 27 | ! close(212) 28 | end subroutine read_namelist 29 | 30 | 31 | -------------------------------------------------------------------------------- /test/src.mitgcm/load_reflect.f90: -------------------------------------------------------------------------------- 1 | subroutine load_reflect() 2 | use global, only: reflect_x,reflect_y,Nx,Ny,Nz,path2uvw 3 | implicit none 4 | open(43,file=trim(path2uvw)//'reflect_x.bin',& 5 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 6 | status='old',recl=4*Nz*(Nx+4)*Ny) 7 | read(43,rec=1) reflect_x(-2:Nx+1,0:Ny-1,0:Nz-1) 8 | close(43) 9 | ! reflect_x(-2:-1,:,:)=reflect_x(Nx-2:Nx-1,:,:) 10 | ! reflect_x(Nx:Nx+1,:,:)=reflect_x(0:1,:,:) 11 | reflect_x(:,:,Nz)=reflect_x(:,:,Nz-1) 12 | reflect_x(:,:,-1)=reflect_x(:,:,0) 13 | print*, "==================================================" 14 | print*, "loading reflect_x" 15 | 16 | open(43,file=trim(path2uvw)//'reflect_y.bin',& 17 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 18 | status='old',recl=4*Nz*(Nx+4)*Ny) 19 | read(43,rec=1) reflect_y(-2:Nx+1,0:Ny-1,0:Nz-1) 20 | close(43) 21 | ! reflect_y(-2:-1,:,:)=reflect_y(Nx-2:Nx-1,:,:) 22 | ! reflect_y(Nx:Nx+1,:,:)=reflect_y(0:1,:,:) 23 | reflect_y(:,:,Nz)=reflect_y(:,:,Nz-1) 24 | reflect_y(:,:,-1)=reflect_y(:,:,0) 25 | print*, "==================================================" 26 | print*, "loading reflect_y" 27 | 28 | 29 | end subroutine load_reflect 30 | -------------------------------------------------------------------------------- /src/load_reflect.f90: -------------------------------------------------------------------------------- 1 | subroutine load_reflect() 2 | #include "cpp_options.h" 3 | 4 | #ifdef reflective_continent 5 | 6 | use global, only: reflect_x,reflect_y,Nx,Ny,Nz,path2uvw 7 | implicit none 8 | open(43,file='../data/reflect_x.bin',& 9 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 10 | status='old',recl=4*Nz*(Nx+4)*Ny) 11 | read(43,rec=1) reflect_x(-2:Nx+1,0:Ny-1,0:Nz-1) 12 | close(43) 13 | ! reflect_x(-2:-1,:,:)=reflect_x(Nx-2:Nx-1,:,:) 14 | ! reflect_x(Nx:Nx+1,:,:)=reflect_x(0:1,:,:) 15 | reflect_x(:,:,Nz)=reflect_x(:,:,Nz-1) 16 | reflect_x(:,:,-1)=reflect_x(:,:,0) 17 | print*, "==================================================" 18 | print*, "loading reflect_x" 19 | 20 | open(43,file='../data/reflect_y.bin',& 21 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 22 | status='old',recl=4*Nz*(Nx+4)*Ny) 23 | read(43,rec=1) reflect_y(-2:Nx+1,0:Ny-1,0:Nz-1) 24 | close(43) 25 | ! reflect_y(-2:-1,:,:)=reflect_y(Nx-2:Nx-1,:,:) 26 | ! reflect_y(Nx:Nx+1,:,:)=reflect_y(0:1,:,:) 27 | reflect_y(:,:,Nz)=reflect_y(:,:,Nz-1) 28 | reflect_y(:,:,-1)=reflect_y(:,:,0) 29 | print*, "==================================================" 30 | print*, "loading reflect_y" 31 | 32 | #endif 33 | 34 | end subroutine load_reflect 35 | -------------------------------------------------------------------------------- /test/src.mitgcm/Makefile: -------------------------------------------------------------------------------- 1 | # ============================================================================ 2 | # Name : Makefile 3 | # Author : 4 | # Version : 5 | # Copyright : Your copyright notice 6 | # Description : Makefile for Hello World in Fortran 7 | # ============================================================================ 8 | 9 | 10 | 11 | objects = global.o allocate_vars.o interp_tracer.o \ 12 | random.o driver_omp.o io.o c_find_particle_index.o \ 13 | c_find_uvw.o c_forward_rk4.o c_interp_trilinear.o \ 14 | c_loop_jump.o init_particles.o c_mixing.o r_namelist.o \ 15 | c_set_boundary.o utils.o open_files.o close_files.o read_pickup.o\ 16 | dump_pickup.o dump_data.o load_reflect.o load_depth.o load_3d.o \ 17 | check_and_dump.o calc_parameters.o load_data.o c_gradient.o c_interp_bilinear.o 18 | #objects = global.o random.o thread.o driver_omp.o 19 | 20 | FORTRAN_COMPILER = gfortran 21 | 22 | FFLAGS = -cpp -Wall -fopenmp -O3 -mcmodel=large -fdefault-integer-8 -fdefault-real-8 23 | #FFLAGS = -cpp -O3 -mcmodel=large 24 | 25 | opt: $(objects); $(FORTRAN_COMPILER) -o opt.ensemble -fopenmp $(objects) 26 | #opt: $(objects); $(FORTRAN_COMPILER) -o opt $(objects) 27 | 28 | %.o: %.f90; $(FORTRAN_COMPILER) ${FFLAGS} -c $< 29 | 30 | clean: 31 | rm $(objects) *.mod 32 | -------------------------------------------------------------------------------- /src/set_file_ids.f90: -------------------------------------------------------------------------------- 1 | subroutine set_file_ids() 2 | 3 | #include "cpp_options.h" 4 | 5 | use global,only : FnPartiInitId,fn_ids,Npts,NPP,& 6 | #ifdef isArgo 7 | save_argo_FnIDs,& 8 | #ifdef saveArgoProfile 9 | save_argo_profileIDs,& 10 | #endif 11 | #endif 12 | 13 | #ifdef isGlider 14 | save_glider_FnIDs,& 15 | #endif 16 | fn_uvwtsg_ids,fn_id_mld,output_dir 17 | 18 | implicit none 19 | integer*8 :: i,j,k 20 | 21 | k=9000 22 | ! file ids 23 | do i=1,11 24 | do j=1,NPP 25 | fn_ids(i,j) = k 26 | k=k+1 27 | enddo 28 | enddo 29 | 30 | 31 | !===> glider file ID 32 | 33 | #ifdef isGlider 34 | do i=1,Npts 35 | do j=1,NPP 36 | save_glider_FnIDs(i,j) = k 37 | k=k+1 38 | enddo 39 | enddo 40 | #endif 41 | print*, '-------+++' 42 | 43 | do i=1,7 44 | fn_uvwtsg_ids(i) = k 45 | k=k+1 46 | enddo 47 | 48 | fn_id_mld=k 49 | k=k+1 50 | FnPartiInitId=k 51 | k=k+1 52 | 53 | #ifdef isArgo 54 | do i =1, Npts 55 | do j=1, NPP 56 | save_argo_FnIDs(i,j)=k 57 | k=k+1 58 | #ifdef saveArgoProfile 59 | save_argo_profileIDs(i,j)=k 60 | k=k+1 61 | #endif 62 | enddo 63 | enddo 64 | #endif 65 | 66 | 67 | call system('mkdir -p '//trim(output_dir)) 68 | 69 | end subroutine set_file_ids 70 | -------------------------------------------------------------------------------- /test/src.mitgcm/c_forward_rk4.f90: -------------------------------------------------------------------------------- 1 | 2 | subroutine rk4(SNPP) 3 | ! integrate in time using RK4 scheme 4 | use global, only : tt,Npts,iswitch,xyz,dt,Nx,Ny,Nz,uvwp,dt_file,t_amend,useKh,saveTSG 5 | 6 | implicit none 7 | real*8, dimension(3) :: x0,x1,uvw 8 | integer*8 :: t0,t1,ip,IPP 9 | integer*8, intent(in) :: SNPP 10 | 11 | t0=abs(iswitch-1) 12 | t1=iswitch 13 | do IPP=1,SNPP 14 | !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(x0,x1,uvw,ip) SHARED(IPP,SNPP,Npts,xyz,t_amend,t0,t1,dt,useKh) 15 | do ip=1,Npts 16 | x0=xyz(ip,:,IPP) 17 | x1=xyz(ip,:,IPP) 18 | 19 | call find_particle_uvw(0.0d0,ip,IPP,t0,t1,uvw) 20 | 21 | x1=x1+dt*uvw/6d0 22 | xyz(ip,:,IPP)=x0+dt*uvw/2d0 23 | 24 | call find_particle_uvw(t_amend,ip,IPP,t0,t1,uvw) 25 | x1=x1+dt*uvw/3d0 26 | xyz(ip,:,IPP)=x0+dt*uvw/2d0 27 | 28 | call find_particle_uvw(t_amend,ip,IPP,t0,t1,uvw) 29 | x1=x1+dt*uvw/3d0 30 | xyz(ip,:,IPP)=x0+dt*uvw 31 | 32 | call find_particle_uvw(t_amend*2d0,ip,IPP,t0,t1,uvw) 33 | xyz(ip,:,IPP)=x1+dt*uvw/6d0 34 | enddo 35 | !$OMP END PARALLEL DO 36 | if (useKh) then 37 | call apply_mixing(IPP) 38 | endif 39 | call set_boundary(IPP) 40 | enddo 41 | 42 | end subroutine rk4 43 | -------------------------------------------------------------------------------- /src/check_and_save.f90: -------------------------------------------------------------------------------- 1 | subroutine check_and_save(SNPP) 2 | #include "cpp_options.h" 3 | 4 | use global, only :tt,saveFreq,diagFreq,pickupFreq,& 5 | rec_num,dt_reinit,iswitch,pickup,count_step 6 | implicit none 7 | INTEGER*8 :: t0,t1,IPP 8 | INTEGER*8, intent(in) :: SNPP 9 | 10 | !$OMP PARALLEL SECTIONS 11 | 12 | !$OMP SECTION 13 | 14 | if (mod(count_step,saveFreq) .eq. 0) then 15 | t0=abs(iswitch-1) 16 | t1=iswitch 17 | 18 | #ifdef monitoring 19 | print*, "write data to files at step ",count_step,' tt=',tt 20 | #endif 21 | 22 | do IPP=1,SNPP 23 | 24 | #ifdef saveTSG 25 | call interp_tracer(t0,t1,IPP) 26 | #endif 27 | 28 | #ifdef saveGradient 29 | call calc_gradient(t0,IPP) 30 | #endif 31 | 32 | call save_data(IPP) 33 | 34 | enddo 35 | 36 | endif 37 | 38 | !$OMP SECTION 39 | 40 | #ifdef monitoring 41 | if (mod(int(tt),diagFreq) .eq. 0) then 42 | call diag() 43 | endif 44 | #endif 45 | 46 | if (mod(tt,pickupFreq) .eq. 0) then 47 | call save_pickup() 48 | endif 49 | 50 | !$OMP SECTION 51 | !reinitialize particles if invoked 52 | if (dt_reinit>0 .and. mod(tt,dt_reinit) .eq. 0) then 53 | pickup=0d0 54 | call init_particles() 55 | endif 56 | !$OMP END PARALLEL SECTIONS 57 | end subroutine check_and_save 58 | -------------------------------------------------------------------------------- /scripts/gen_simple_velocity.py: -------------------------------------------------------------------------------- 1 | import numpy as np 2 | import scipy as sp 3 | import pylab as plt 4 | 5 | 6 | def gen_grid(nx,ny,nz): 7 | i_f=np.arange(nx) 8 | i_c=np.arange(nx)+0.5 9 | j_f=np.arange(ny) 10 | j_c=np.arange(ny)+0.5 11 | dxx=dyy=2e3 12 | dx=np.ones((ny,nx))*dxx 13 | dy=np.ones((ny,nx))*dyy 14 | 15 | x_f=i_f*dxx 16 | x_c=i_c*dxx 17 | 18 | y_f=j_f*dxx 19 | y_c=j_c*dxx 20 | 21 | psi0=1e4 22 | 23 | x0=nx/2.0*dxx 24 | y0=ny/2.0*dyy 25 | r = dxx * 10 26 | xu,yu=np.meshgrid(x_f,y_c) 27 | xv,yv=np.meshgrid(x_c,y_f) 28 | 29 | u=psi0/r**2*(yu-x0)*np.exp((-(xu-x0)**2-(yu-y0)**2)/r**2) 30 | v=-psi0/r**2*(xv-y0)*np.exp((-(xv-x0)**2-(yv-y0)**2)/r**2) 31 | 32 | w=np.zeros((nz,ny,nx)) 33 | 34 | u=u*np.ones_like(w) 35 | v=v*np.ones_like(w) 36 | 37 | hfacc=np.ones_like(w) 38 | 39 | drf=np.ones((nz))*10.0 40 | 41 | hfacc.astype('>f4').tofile('hFacC.data') 42 | dx.astype('>f4').tofile('DXG.data') 43 | dy.astype('>f4').tofile('DYG.data') 44 | drf.astype('>f4').tofile('DRF.data') 45 | 46 | for i in range(20): 47 | app='_%04i.data'%i 48 | u.astype('>f4').tofile('UVEL'+app) 49 | v.astype('>f4').tofile('VVEL'+app) 50 | w.astype('>f4').tofile('WVEL'+app) 51 | print u.max() 52 | 53 | plt.quiver(u[0,...],v[0,...]) 54 | plt.show() 55 | 56 | return 57 | 58 | gen_grid(30,30,10) 59 | -------------------------------------------------------------------------------- /test/src.mitgcm/check_and_dump.f90: -------------------------------------------------------------------------------- 1 | subroutine check_and_dump(SNPP) 2 | 3 | use global, only :tt,dumpFreq,diagFreq,pickupFreq,& 4 | rec_num,dt_reinit,iswitch,saveTSG,pickup 5 | implicit none 6 | INTEGER*8 :: t0,t1,IPP 7 | INTEGER*8, intent(in) :: SNPP 8 | 9 | !$OMP PARALLEL SECTIONS 10 | 11 | !$OMP SECTION 12 | if (mod(tt,dumpFreq) .eq. 0.0) then 13 | t0=abs(iswitch-1) 14 | t1=iswitch 15 | print*, "write data to files at step ",rec_num,' tt=',tt 16 | do IPP=1,SNPP 17 | if (saveTSG) then 18 | call interp_tracer(t0,t1,IPP) 19 | call c_gradient(t0,IPP) 20 | endif 21 | call dump_data(IPP) 22 | enddo 23 | 24 | endif 25 | 26 | !$OMP SECTION 27 | !call count_stagnant() 28 | if (mod(tt,diagFreq) .eq. 0) then 29 | call diag() 30 | endif 31 | 32 | !$OMP SECTION 33 | if (mod(tt,pickupFreq) .eq. 0) then 34 | print*, "===========================================" 35 | print*, " Dump pickup data at record ", rec_num 36 | print*, "===========================================" 37 | call dump_pickup() 38 | endif 39 | 40 | !$OMP SECTION 41 | !reinitialize particles if invoked 42 | if (dt_reinit>0 .and. mod(tt,dt_reinit) .eq. 0) then 43 | pickup=0d0 44 | call init_particles() 45 | endif 46 | !$OMP END PARALLEL SECTIONS 47 | end subroutine check_and_dump 48 | -------------------------------------------------------------------------------- /docs/source/index.rst: -------------------------------------------------------------------------------- 1 | .. Octopus documentation master file, created by 2 | sphinx-quickstart on Sun Mar 25 22:02:55 2018. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Octopus 7 | ========= 8 | 9 | A tool for fast Lagrangian trajectory calculation 10 | ----------------------------------------------- 11 | 12 | This fortran code is used to calculate particle trajectories using three dimensional velocity fields from numerical models, e.g., MITgcm (https://github.com/MITgcm/MITgcm). The current version is setup based on C-grid. 13 | 14 | **Current status**: testing the volume conservation. 15 | 16 | Offline calculation of Lagrangian trajectories 17 | 18 | This model is in a development stage. Email me for questions. There are two configurations: Lagrangian particle and Argo float. Use "make" to compile the code for Lagrangian particle simulation. Use "make argo" for simulating Argo float. Before running the model, go to scripts folder and run "python gen_data.py" to compute the binary files used by the code. 19 | 20 | Jinbo Wang 21 | 22 | Jet Propulsion Labortory, Caltech 23 | 24 | 11/16/2020 25 | 26 | .. toctree:: 27 | :maxdepth: 2 28 | :caption: Contents: 29 | 30 | 31 | customize_velocity.rst 32 | build.rst 33 | argo.mode.rst 34 | 35 | 36 | Indices and tables 37 | ================== 38 | 39 | * :ref:`genindex` 40 | * :ref:`modindex` 41 | * :ref:`search` 42 | -------------------------------------------------------------------------------- /src/load_uvw_sose_iter100.f90: -------------------------------------------------------------------------------- 1 | subroutine load_uv(irec,ut,vt,wt) 2 | use global, only : Nx,Ny,Nz,Nrecs,fns,path2uvw,fn_UVEL,fn_VVEL,fn_WVEL 3 | implicit none 4 | integer*4, intent(in) :: irec 5 | real*4, dimension(0:Nx,0:Ny-1,0:Nz-1), intent(out) :: ut,vt,wt 6 | !character(255), parameter :: path2uvw='/mdata4/mmazloff/SOSE/ITERS/SO6_Iter100/' 7 | 8 | !open(0,file=trim(path2uvw)//'UVEL.0000000100.data',& 9 | open(0,file=trim(path2uvw)//trim(fn_UVEL),& 10 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 11 | status='old',recl=4*Nx*Ny*Nz) 12 | !open(1,file=trim(path2uvw)//'VVEL.0000000100.data',& 13 | open(1,file=trim(path2uvw)//trim(fn_VVEL),& 14 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 15 | status='old',recl=4*Nx*Ny*Nz) 16 | !open(2,file=trim(path2uvw)//'WVEL.0000000100.data',& 17 | open(2,file=trim(path2uvw)//trim(fn_WVEL),& 18 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 19 | status='old',recl=4*Nx*Ny*Nz) 20 | print*, "loading velocity fields, u ..............." 21 | read(0,rec=irec) ut(0:Nx-1,:,:) 22 | print*, "loading velocity fields, v ..............." 23 | read(1,rec=irec) vt(0:Nx-1,:,:) 24 | print*, "loading velocity fields, w ..............." 25 | read(2,rec=irec) wt(0:Nx-1,:,:) 26 | ut(Nx,:,:)=ut(0,:,:) 27 | vt(Nx,:,:)=vt(0,:,:) 28 | wt(Nx,:,:)=wt(0,:,:) 29 | wt=-1.0*wt 30 | close(0) 31 | close(1) 32 | close(2) 33 | 34 | end subroutine load_uv 35 | -------------------------------------------------------------------------------- /test/src.mitgcm/load_uvw_sose_iter100.f90: -------------------------------------------------------------------------------- 1 | subroutine load_uv(irec,ut,vt,wt) 2 | use global, only : Nx,Ny,Nz,Nrecs,fns,path2uvw,fn_UVEL,fn_VVEL,fn_WVEL 3 | implicit none 4 | integer*4, intent(in) :: irec 5 | real*4, dimension(0:Nx,0:Ny-1,0:Nz-1), intent(out) :: ut,vt,wt 6 | !character(255), parameter :: path2uvw='/mdata4/mmazloff/SOSE/ITERS/SO6_Iter100/' 7 | 8 | !open(0,file=trim(path2uvw)//'UVEL.0000000100.data',& 9 | open(0,file=trim(path2uvw)//trim(fn_UVEL),& 10 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 11 | status='old',recl=4*Nx*Ny*Nz) 12 | !open(1,file=trim(path2uvw)//'VVEL.0000000100.data',& 13 | open(1,file=trim(path2uvw)//trim(fn_VVEL),& 14 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 15 | status='old',recl=4*Nx*Ny*Nz) 16 | !open(2,file=trim(path2uvw)//'WVEL.0000000100.data',& 17 | open(2,file=trim(path2uvw)//trim(fn_WVEL),& 18 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 19 | status='old',recl=4*Nx*Ny*Nz) 20 | print*, "loading velocity fields, u ..............." 21 | read(0,rec=irec) ut(0:Nx-1,:,:) 22 | print*, "loading velocity fields, v ..............." 23 | read(1,rec=irec) vt(0:Nx-1,:,:) 24 | print*, "loading velocity fields, w ..............." 25 | read(2,rec=irec) wt(0:Nx-1,:,:) 26 | ut(Nx,:,:)=ut(0,:,:) 27 | vt(Nx,:,:)=vt(0,:,:) 28 | wt(Nx,:,:)=wt(0,:,:) 29 | wt=-1.0*wt 30 | close(0) 31 | close(1) 32 | close(2) 33 | 34 | end subroutine load_uv 35 | -------------------------------------------------------------------------------- /test/src.mitgcm/init_particles.f90: -------------------------------------------------------------------------------- 1 | subroutine init_particles(IPP) 2 | use global, only : Npts,iswitch,xyz,fn_parti_init,tsg,& 3 | target_density,pickup,rec_num,tt,dt_file,pk2f,NPP 4 | implicit none 5 | integer*8, intent(in):: IPP 6 | ! integer*8:: i 7 | 8 | if (pickup>0) then 9 | !call read_pickup() 10 | !do i=1,NPP 11 | !call set_boundary(i) 12 | call load_data(IPP) 13 | !enddo 14 | rec_num = floor(tt/dt_file)+1 15 | ! call load_uvwtsg(rec_num,0) 16 | ! call load_uvwtsg(rec_num+1,1) 17 | ! iswitch=1 18 | print*, "pickup data maxval z, pk2f, rec_num", maxval(xyz(:,3,:)),maxval(pk2f),rec_num 19 | else 20 | 21 | print*, "------------------------------------" 22 | print*, "initialize particles for case", IPP 23 | open(10,file=trim(fn_parti_init),form='unformatted',& 24 | recl=8*Npts*3,convert='BIG_ENDIAN',& 25 | access='direct',status='old') 26 | read(10,rec=1) xyz(:,:,IPP) 27 | print*, "maximum init", maxval(xyz(:,1,IPP)),maxval(xyz(:,2,IPP)),maxval(xyz(:,3,IPP)) 28 | 29 | call set_boundary(IPP) 30 | ! Reset the particle depth to find the particle density 31 | if (target_density>0) then 32 | tsg(:,3,IPP)=target_density 33 | call jump(IPP) 34 | endif 35 | close(10) 36 | endif 37 | !call load_uv(rec_num,u0,v0,w0) 38 | !call load_uv(rec_num+1,u1,v1,w1) 39 | !call load_tsg(rec_num,theta0,salt0,gamma0) 40 | !call load_tsg(rec_num+1,theta1,salt1,gamma1) 41 | 42 | end subroutine init_particles 43 | 44 | -------------------------------------------------------------------------------- /src/calc_gradient.f90: -------------------------------------------------------------------------------- 1 | subroutine calc_gradient(t0,IPP) 2 | 3 | use global, only: uu,vv,dic,djc,dkc,dif,djf,dkf,pi2c,pj2c,pk2c,pi2f,pj2f,grad,npts,dxg_r,dyg_r,Npts 4 | implicit none 5 | integer*8, intent(in) :: IPP,t0 6 | real*8 :: tmp0,tmp1,dx,dy,dr 7 | integer*8:: i,j,k,ip 8 | 9 | !$OMP PARALLEL DO PRIVATE(ip,i,j,k,dx,dy,dr,tmp0,tmp1) SHARED(IPP,t0,dic,djc,dkc,uu,vv,grad,dxg_r,dyg_r) SCHEDULE(dynamic) 10 | do ip=1,npts 11 | 12 | dx=dif(ip,IPP) 13 | dy=djc(ip,IPP) 14 | dr=dkc(ip,IPP) 15 | 16 | !du/dx 17 | i=pi2f(ip,IPP) 18 | j=pj2c(ip,IPP) 19 | k=pk2c(ip,IPP) 20 | call interp_bilinear(dy,dr,uu(i,j:j+1,k:k+1,t0),tmp0) 21 | call interp_bilinear(dy,dr,uu(i+1,j:j+1,k:k+1,t0),tmp1) 22 | grad(ip,1,IPP)=(tmp1-tmp0)*dxg_r(i,j) 23 | !du/dy 24 | call interp_bilinear(dx,dr,uu(i:i+1,j,k:k+1,t0),tmp0) 25 | call interp_bilinear(dx,dr,uu(i:i+1,j+1,k:k+1,t0),tmp1) 26 | grad(ip,2,IPP)=(tmp1-tmp0)*dyg_r(i,j) 27 | 28 | !dv/dx 29 | i=pi2c(ip,IPP) 30 | j=pj2f(ip,IPP) 31 | 32 | dy=djf(ip,IPP) 33 | dx=dic(ip,IPP) 34 | 35 | call interp_bilinear(dy,dr,vv(i,j:j+1,k:k+1,t0),tmp0) 36 | call interp_bilinear(dy,dr,vv(i+1,j:j+1,k:k+1,t0),tmp1) 37 | grad(ip,3,IPP)=(tmp1-tmp0)*dxg_r(i,j) 38 | !dv/dy 39 | 40 | call interp_bilinear(dx,dr,vv(i:i+1,j,k:k+1,t0),tmp0) 41 | call interp_bilinear(dx,dr,vv(i:i+1,j+1,k:k+1,t0),tmp1) 42 | grad(ip,4,IPP)=(tmp1-tmp0)*dyg_r(i,j) 43 | 44 | 45 | enddo 46 | !$OMP END PARALLEL DO 47 | 48 | end subroutine calc_gradient 49 | -------------------------------------------------------------------------------- /test/src.mitgcm/c_gradient.f90: -------------------------------------------------------------------------------- 1 | subroutine c_gradient(t0,IPP) 2 | 3 | use global, only: uu,vv,dic,djc,dkc,dif,djf,dkf,pi2c,pj2c,pk2c,pi2f,pj2f,grad,npts,dxg_r,dyg_r,Npts 4 | implicit none 5 | integer*8, intent(in) :: IPP,t0 6 | real*8 :: tmp0,tmp1,dx,dy,dr 7 | integer*8:: i,j,k,ip 8 | 9 | !$OMP PARALLEL DO PRIVATE(ip,i,j,k,dx,dy,dr,tmp0,tmp1) SHARED(IPP,t0,dic,djc,dkc,uu,vv,grad,dxg_r,dyg_r) SCHEDULE(dynamic) 10 | do ip=1,npts 11 | 12 | dx=dif(ip,IPP) 13 | dy=djc(ip,IPP) 14 | dr=dkc(ip,IPP) 15 | 16 | !du/dx 17 | i=pi2f(ip,IPP) 18 | j=pj2c(ip,IPP) 19 | k=pk2c(ip,IPP) 20 | call interp_bilinear(dy,dr,uu(i,j:j+1,k:k+1,t0),tmp0) 21 | call interp_bilinear(dy,dr,uu(i+1,j:j+1,k:k+1,t0),tmp1) 22 | grad(ip,1,IPP)=(tmp1-tmp0)*dxg_r(i,j) 23 | !du/dy 24 | call interp_bilinear(dx,dr,uu(i:i+1,j,k:k+1,t0),tmp0) 25 | call interp_bilinear(dx,dr,uu(i:i+1,j+1,k:k+1,t0),tmp1) 26 | grad(ip,2,IPP)=(tmp1-tmp0)*dyg_r(i,j) 27 | 28 | !dv/dx 29 | i=pi2c(ip,IPP) 30 | j=pj2f(ip,IPP) 31 | 32 | dy=djf(ip,IPP) 33 | dx=dic(ip,IPP) 34 | 35 | call interp_bilinear(dy,dr,vv(i,j:j+1,k:k+1,t0),tmp0) 36 | call interp_bilinear(dy,dr,vv(i+1,j:j+1,k:k+1,t0),tmp1) 37 | grad(ip,3,IPP)=(tmp1-tmp0)*dxg_r(i,j) 38 | !dv/dy 39 | 40 | call interp_bilinear(dx,dr,vv(i:i+1,j,k:k+1,t0),tmp0) 41 | call interp_bilinear(dx,dr,vv(i:i+1,j+1,k:k+1,t0),tmp1) 42 | grad(ip,4,IPP)=(tmp1-tmp0)*dyg_r(i,j) 43 | 44 | 45 | enddo 46 | !$OMP END PARALLEL DO 47 | 48 | end subroutine c_gradient 49 | -------------------------------------------------------------------------------- /docs/source/customize_velocity.rst: -------------------------------------------------------------------------------- 1 | Customize velocity fields 2 | ========================= 3 | 4 | The following can help you get started to implement your own analytic functions for velocities. 5 | 6 | The procedure of loading velocities 7 | -------------------------------------- 8 | 9 | There are usually many individual files used to save velocity data from numerical simulations. In order to read it, we need to map a list of filename to those data. The relavent fortran Character variables are defined in global.f90 as the following block. 10 | 11 | :: 12 | 13 | !file names 14 | INTEGER*8, ALLOCATABLE :: fn_ids(:,:) 15 | INTEGER*8 :: fn_uvwtsg_ids(7),fn_xyz_tsg_mld_ids(3),fn_id_mld,FnPartiInitId 16 | 17 | INTEGER*8 :: file_i0 18 | INTEGER*8 :: filename_increment=1 19 | CHARACTER (len=64) :: casename,path2uvw,path2grid,FnPartiInit,output_dir,fn_phihyd,fn_mld 20 | CHARACTER (len=64) :: fn_UVEL,fn_VVEL,fn_WVEL,fn_THETA,fn_SALT,fn_GAMMA 21 | 22 | CHARACTER (len=64), dimension(Nrecs, Nvar2read) :: filenames 23 | 24 | 25 | If one-record-per-file, the program will use c_filenames.f90 to pre-calculate the filenames and save them to variable **filenames(N,M)**, where **N** is the number of records and **M** is the number of variables. 26 | 27 | The velocity data will be loaded into memeory by the subroutine load_uvw() in **io.f90**. 28 | 29 | The velocity data will next be used by **find_particle_uvw()** in **get_velocity.f90**. 30 | 31 | After the velocity data interpolated onto the particle positions, **rk4()** will be used to intergrate the trajectory position. Because **rk4** uses several time steps, the subroutine **find_particle_uvw()** will be used four times in **rk4**, each time with an updated velocity. 32 | 33 | 34 | -------------------------------------------------------------------------------- /scripts/glue_opt_data.py: -------------------------------------------------------------------------------- 1 | """ 2 | Glue outputs into a single binary file 3 | 4 | Jinbo Wang 5 | 6 | Scripps Institution of Oceanography 7 | August 26, 2015 """ 8 | 9 | 10 | import glob,os,sys 11 | import numpy as np 12 | 13 | #change this to the path of the data output 14 | folder='/home/jwang0/temp_project/offline_particle/sose100/DP/run/' 15 | 16 | #you can glue one case or multi-cases at the same time, 'DIMES_0001' etc. are casenames 17 | casenames=['DIMES_0001','DIMES_0002','DIMES_0003'] 18 | casenames=['DIMES_0006'] 19 | 20 | #specify particle numbers and case numbers (the NPP value in the namelist) here: 21 | npts=5000 22 | npp=73 23 | 24 | #you don't need to change the following. 25 | varn=['XYZ','MLD','TSG','GRAD'] 26 | nn = [3,1,4,4] 27 | for cn in casenames: 28 | for i in range(1,npp+1): 29 | casename='%s_%04i'%(cn,i) 30 | for iv,var in enumerate(varn): 31 | fns=sorted(glob.glob(folder+casename+'.%s.*.data'%var)) 32 | print casename,var,"total %i files"%len(fns) 33 | f=open('filenames_%s'%casename,'w') 34 | n=nn[iv] 35 | d=np.fromfile(fns[0],'>f4') 36 | print d.shape,n 37 | d=d.reshape(n,npts) 38 | nxy,nopt=d.shape 39 | del d 40 | t0=fns[0].split('.')[-2] 41 | t1=fns[-1].split('.')[-2] 42 | print t0,t1 43 | dds=np.memmap(casename+'.%s.%s.%s.data'%(var,t0,t1),dtype='>f4',shape=(len(fns),n,nopt),mode='write') 44 | for i in range(len(fns)): 45 | d=np.fromfile(fns[i],'>f4').reshape(n,-1) 46 | f.writelines(fns[i]) 47 | dds[i,...]=d 48 | del d 49 | f.close() 50 | del dds, 51 | 52 | -------------------------------------------------------------------------------- /src/allocate_vars.f90: -------------------------------------------------------------------------------- 1 | subroutine allocate_parti() 2 | #include "cpp_options.h" 3 | 4 | use global 5 | !, only :xyz, xyz0, uvwp, dxyz_fac, tsg,& 6 | ! pi2f,pj2f,pk2f,pi2c,pj2c,pk2c,& 7 | ! dif, djf, dkf, dic, djc, dkc, parti_mld,& 8 | ! NPP,Npts,fn_ids,grad 9 | print*, "----------------------------------------------" 10 | print*, "start allocation of variables ......" 11 | 12 | 13 | ALLOCATE ( xyz(Npts,3,NPP), & 14 | xyz0(Npts,3,NPP), & 15 | uvwp(Npts,3,NPP), & 16 | dxyz_fac(Npts,3,NPP) ) 17 | 18 | ALLOCATE (tsg(Npts,4,NPP)) 19 | 20 | #ifdef isArgo 21 | ALLOCATE (argo_clock(Npts,2,NPP),& 22 | save_argo_FnIDs(Npts,NPP) ) 23 | argo_clock(:,:,:)=0 24 | #ifdef saveArgoProfile 25 | ALLOCATE ( save_argo_profileIDs(Npts,NPP) ) 26 | #endif 27 | 28 | #endif 29 | 30 | tsg=0e0 31 | 32 | 33 | #ifdef saveGradient 34 | ALLOCATE (grad(Npts,5,NPP)) 35 | #endif 36 | 37 | ALLOCATE ( pi2f(Npts,NPP),& 38 | pj2f(Npts,NPP),& 39 | pk2f(Npts,NPP),& 40 | pi2c(Npts,NPP),& 41 | pj2c(Npts,NPP),& 42 | pk2c(Npts,NPP),& 43 | dif(Npts,NPP), & 44 | djf(Npts,NPP), & 45 | dkf(Npts,NPP), & 46 | dic(Npts,NPP), & 47 | djc(Npts,NPP), & 48 | dkc(Npts,NPP), & 49 | parti_mld(Npts,NPP) ) 50 | 51 | #ifdef isGlider 52 | ALLOCATE ( glider_clock(Npts,2,NPP),& 53 | glider_position(Npts,4,NPP),& 54 | glider_uv(Npts,2,NPP),& 55 | glider_angle(Npts,NPP),& 56 | glider_cycle(Npts,NPP),& 57 | save_glider_FnIDs(Npts,NPP) ) 58 | #endif 59 | 60 | 61 | ALLOCATE ( fn_ids(20,NPP) ) 62 | 63 | print*, "end allocation of variables ......" 64 | 65 | end subroutine allocate_parti 66 | -------------------------------------------------------------------------------- /src/load_data.f90: -------------------------------------------------------------------------------- 1 | subroutine load_data(IPP) 2 | use omp_lib 3 | use global, only: casename,tt,fn_ids,xyz,tsg,& 4 | Npts,parti_mld,DumpClock,& 5 | NPP,output_dir,pickup 6 | implicit none 7 | character(len=128) :: fn 8 | character(len=16) :: fn1 9 | ! integer*8 :: iwrite 10 | integer*8,intent(in) :: IPP 11 | real*4 :: xyz1(Npts,3) ,xyz2(Npts,3),xyz3(Npts) 12 | 13 | ! iwrite=int(tt/DumpClock)+1 14 | !tt=(pickup-1)*DumpClock 15 | ! write(fn,"(I10.10)") iwrite 16 | write(fn,"(I10.10)") int(pickup,8) 17 | write(fn1,"(I4.4)") IPP 18 | 19 | !$OMP PARALLEL SECTIONS 20 | !$OMP SECTION 21 | open(fn_ids(1,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.XYZ.'//trim(fn)//'.data',& 22 | access='direct',form='unformatted', convert='BIG_ENDIAN',recl=3*4*Npts,status='old') 23 | read(fn_ids(1,IPP),rec=1) xyz1 24 | close(fn_ids(1,IPP)) 25 | xyz(:,:,IPP)=real(xyz1,8) 26 | 27 | #ifdef saveTSG 28 | !$OMP SECTION 29 | open(fn_ids(2,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.TSG.'//trim(fn)//'.data',& 30 | access='direct',form='unformatted',convert='BIG_ENDIAN',recl=3*4*Npts,status='old') 31 | read(fn_ids(2,IPP),rec=1) xyz2 32 | close(fn_ids(2,IPP)) 33 | tsg(:,:,IPP)=real(xyz2,8) 34 | #endif 35 | 36 | #ifdef use_mixedlayer_shuffle 37 | !$OMP SECTION 38 | open(fn_ids(3,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.MLD.'//trim(fn)//'.data',& 39 | access='direct',form='unformatted',convert='BIG_ENDIAN',recl=4*Npts,status='old') 40 | read(fn_ids(3,IPP),rec=1) xyz3 41 | close(fn_ids(3,IPP)) 42 | parti_mld(:,IPP)=real(xyz3,8) 43 | #endif 44 | 45 | 46 | !$OMP END PARALLEL SECTIONS 47 | 48 | end subroutine load_data 49 | -------------------------------------------------------------------------------- /test/src.mitgcm/load_data.f90: -------------------------------------------------------------------------------- 1 | subroutine load_data(IPP) 2 | use omp_lib 3 | use global, only: casename,tt,fn_ids,xyz,tsg,& 4 | Npts,parti_mld,DumpClock,saveTSG,& 5 | useMLD,NPP,output_dir,pickup 6 | implicit none 7 | character(len=128) :: fn 8 | character(len=16) :: fn1 9 | ! integer*8 :: iwrite 10 | integer*8,intent(in) :: IPP 11 | real*4 :: xyz1(Npts,3),xyz2(Npts,3),xyz3(Npts) 12 | 13 | ! iwrite=int(tt/DumpClock)+1 14 | !tt=(pickup-1)*DumpClock 15 | ! write(fn,"(I10.10)") iwrite 16 | write(fn,"(I10.10)") int(pickup,8) 17 | write(fn1,"(I4.4)") IPP 18 | 19 | !$OMP PARALLEL SECTIONS 20 | !$OMP SECTION 21 | open(fn_ids(1,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.XYZ.'//trim(fn)//'.data',& 22 | access='direct',form='unformatted', convert='BIG_ENDIAN',recl=3*4*Npts,status='old') 23 | read(fn_ids(1,IPP),rec=1) xyz1 24 | close(fn_ids(1,IPP)) 25 | xyz(:,:,IPP)=real(xyz1,8) 26 | 27 | !$OMP SECTION 28 | if (saveTSG) then 29 | open(fn_ids(2,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.TSG.'//trim(fn)//'.data',& 30 | access='direct',form='unformatted',convert='BIG_ENDIAN',recl=3*4*Npts,status='old') 31 | read(fn_ids(2,IPP),rec=1) xyz2 32 | close(fn_ids(2,IPP)) 33 | tsg(:,:,IPP)=real(xyz2,8) 34 | endif 35 | 36 | !$OMP SECTION 37 | if (useMLD) then 38 | open(fn_ids(3,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.MLD.'//trim(fn)//'.data',& 39 | access='direct',form='unformatted',convert='BIG_ENDIAN',recl=4*Npts,status='old') 40 | read(fn_ids(3,IPP),rec=1) xyz3 41 | close(fn_ids(3,IPP)) 42 | parti_mld(:,IPP)=real(xyz3,8) 43 | endif 44 | 45 | 46 | !$OMP END PARALLEL SECTIONS 47 | 48 | end subroutine load_data 49 | -------------------------------------------------------------------------------- /src/init_particles.f90: -------------------------------------------------------------------------------- 1 | subroutine init_particles(IPP) 2 | #include "cpp_options.h" 3 | 4 | ! use global, only : Npts,iswitch,xyz,tsg,& 5 | ! target_density,pickup,& 6 | ! rec_num,tt,dt_file,pk2f,& 7 | ! NPP,FnPartiInit,glider_position 8 | use global 9 | 10 | implicit none 11 | integer*8, intent(in):: IPP 12 | 13 | print*, "initialize particles for case", IPP 14 | 15 | open(FnPartiInitId,file=trim(FnPartiInit),form='unformatted',& 16 | recl=8*Npts*3,convert='BIG_ENDIAN',& 17 | access='direct',status='old') 18 | read(FnPartiInitId,rec=1) xyz(:,:,IPP) 19 | close(FnPartiInitId) 20 | 21 | print*, "initial x",xyz(:,1,IPP) 22 | print*, "initial y",xyz(:,2,IPP) 23 | print*, "initial z",xyz(:,3,IPP) 24 | 25 | #ifdef isArgo 26 | xyz(:,3,IPP)=0 27 | #endif 28 | 29 | #ifdef isGlider 30 | xyz(:,3,IPP)=0 31 | !xyz(1,1,IPP)= 101.1 32 | !xyz(1,2,IPP)= 200.1 33 | !xyz(2,1,IPP)= 99.9 34 | !xyz(2,2,IPP)= 199.9 35 | 36 | glider_position(:,3,IPP)=xyz(:,1,IPP) 37 | glider_position(:,4,IPP)=xyz(:,2,IPP) 38 | 39 | xyz(:,1:2,IPP)=xyz(:,1:2,IPP)+0.01 40 | !xyz(1,1:2,IPP)=2 41 | glider_position(:,1,IPP)=xyz(:,1,IPP) 42 | glider_position(:,2,IPP)=xyz(:,2,IPP) 43 | 44 | 45 | 46 | 47 | glider_clock(:,1,IPP)=0 48 | glider_cycle(:,:)=0 49 | glider_angle(:,:)=60 50 | 51 | #endif 52 | 53 | #ifndef isArgo 54 | #ifndef isGlider 55 | call set_boundary(IPP) 56 | ! Reset the particle depth to find the particle density 57 | if (target_density>0) then 58 | tsg(:,3,IPP)=target_density 59 | call jump(IPP) 60 | endif 61 | #endif 62 | #endif 63 | 64 | print*, "maximum init", maxval(xyz(:,1,IPP)),maxval(xyz(:,2,IPP)),maxval(xyz(:,3,IPP)) 65 | 66 | end subroutine init_particles 67 | 68 | -------------------------------------------------------------------------------- /test/src.mitgcm/global.f90: -------------------------------------------------------------------------------- 1 | module global 2 | implicit none 3 | include "size.h" 4 | !for particle 5 | integer*8 :: Npts,NPP 6 | 7 | 8 | CHARACTER(32) :: fn_particle_init 9 | REAL*4 , DIMENSION(-2:Nx+1,0:Ny-1,-1:Nz,0:1) :: uu,vv,ww 10 | REAL*4 , DIMENSION(-2:Nx+1,0:Ny-1,-1:Nz,0:1) :: theta,salt,gam 11 | REAL*4 , DIMENSION(-2:Nx+1,0:Ny-1,-1:Nz) :: hFacC 12 | REAL*4 , DIMENSION(-2:Nx+1,0:Ny-1, -1:Nz) :: reflect_x,reflect_y 13 | REAL*4 , DIMENSION(-2:Nx+1,0:Ny-1) :: mld,phihyd 14 | 15 | REAL*4 :: sose_depth(-2:Nx+1,0:Ny-1) 16 | REAL*8, parameter :: PI=3.141592653589793238462643383279502884197d0 17 | REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: xyz, xyz0, uvwp, dxyz_fac, tsg, grad 18 | 19 | !pickup 20 | REAL*8 :: pickup=0 21 | REAL*8 :: pickupFreq=7776000.0 22 | 23 | INTEGER*8, DIMENSION(:,:), ALLOCATABLE :: pi2f,pj2f,pk2f,pi2c,pj2c,pk2c 24 | REAL*8, DIMENSION(:,:), ALLOCATABLE :: dif, djf, dkf, dic, djc, dkc !distance to face and cell center 25 | REAL*8, DIMENSION(:,:), ALLOCATABLE :: parti_mld 26 | 27 | !grid 28 | REAL*8, DIMENSION(-2:Nx+1,0:Ny-1) :: dxg_r, dyg_r 29 | REAL*8, DIMENSION(-1:Nz):: drf_r 30 | REAL*8 :: z2k(5701), k2z(0:420) 31 | 32 | !timing parameters 33 | REAL*8 :: t_amend, dumpFreq,DumpClock=86400, diagFreq, target_density 34 | REAL*8 :: tt,dtp,dt,dt_mld,tstart,tend,tend_file,dt_reinit,dt_case=15*86400 35 | INTEGER*8 :: rec_num 36 | logical :: saveTSG,useMLD,useKh,vel_stationary 37 | integer*8 :: iswitch 38 | 39 | 40 | !file names 41 | INTEGER*8, ALLOCATABLE :: fn_ids(:,:) 42 | INTEGER*8 :: fn_uvwtsg_ids(7),fn_xyz_tsg_mld_ids(3),fn_id_mld 43 | 44 | INTEGER*8 :: file_i0 45 | CHARACTER(255) :: casename,path2uvw,fn_parti_init,fn_UVEL,& 46 | fn_VVEL,fn_WVEL,fn_THETA,fn_SALT,fn_GAMMA,& 47 | output_dir="output",fn_PHIHYD 48 | !mixing parameters 49 | REAL*8 :: Khdiff, Kvdiff, kvdt2, khdt2 50 | 51 | end module global 52 | -------------------------------------------------------------------------------- /test/src.mitgcm/open_files.f90: -------------------------------------------------------------------------------- 1 | subroutine open_files() 2 | use global,only:fn_uvwtsg_ids,fn_ids,fn_id_mld,path2uvw,fn_UVEL,& 3 | fn_VVEL,fn_WVEL,fn_THETA,fn_SALT,fn_GAMMA,fn_PHIHYD,& 4 | Nx,Ny,Nz,useMLD 5 | implicit none 6 | 7 | open(fn_uvwtsg_ids(1),file=trim(path2uvw)//trim(fn_UVEL),& 8 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 9 | status='old',recl=4*Nx*Ny) 10 | open(fn_uvwtsg_ids(2),file=trim(path2uvw)//trim(fn_VVEL),& 11 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 12 | status='old',recl=4*Nx*Ny) 13 | open(fn_uvwtsg_ids(3),file=trim(path2uvw)//trim(fn_WVEL),& 14 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 15 | status='old',recl=4*Nx*Ny) 16 | if (trim(fn_THETA) .ne. '') then 17 | open(fn_uvwtsg_ids(4),file=trim(path2uvw)//trim(fn_THETA),& 18 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 19 | status='old',recl=4*Nx*Ny) 20 | endif 21 | if (trim(fn_SALT) .ne. '') then 22 | open(fn_uvwtsg_ids(5),file=trim(path2uvw)//trim(fn_SALT),& 23 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 24 | status='old',recl=4*Nx*Ny) 25 | endif 26 | if (trim(fn_GAMMA) .ne. '') then 27 | open(fn_uvwtsg_ids(6),file=trim(path2uvw)//trim(fn_GAMMA),& 28 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 29 | status='old',recl=4*Nx*Ny) 30 | endif 31 | if (trim(fn_PHIHYD) .ne. '') then 32 | open(fn_uvwtsg_ids(7),file=trim(path2uvw)//trim(fn_PHIHYD),& 33 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 34 | status='old',recl=4*Nx*Ny) 35 | endif 36 | if (useMLD) then 37 | open(fn_id_mld,file=trim(path2uvw)//'iter100_mld_438x320x2160.bin',& 38 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 39 | status='old',recl=4*Nx*Ny) 40 | endif 41 | 42 | end subroutine open_files 43 | -------------------------------------------------------------------------------- /src/read_namelist.f90: -------------------------------------------------------------------------------- 1 | subroutine read_namelist() 2 | #include "cpp_options.h" 3 | !========================================= 4 | ! read configuration file 5 | ! use global, only : casename,path2uvw,path2grid,& 6 | ! dt,dt_reinit,tend,dt_case,& 7 | ! dt_mld,pickupFreq,pickup,saveFreq,diagFreq,tstart,FnPartiInit,& 8 | ! target_density,Khdiff,Kvdiff,NPP,Npts,output_dir,& 9 | ! fn_PHIHYD,fn_MLD,DumpClock 10 | 11 | use global 12 | 13 | implicit none 14 | 15 | #ifdef isGlider 16 | namelist /PARAMG/ parking_time,surfacing_time,dive_depth,absv 17 | #endif 18 | 19 | #ifdef isArgo 20 | namelist /PARAMA/ parking_time,surfacing_time,parking_depth,max_depth 21 | #endif 22 | 23 | #ifdef one_file_per_step 24 | namelist /PARAM/ casename,path2uvw,path2grid,& 25 | dt,tend,& 26 | pickup,pickupFreq,saveFreq,diagFreq,tstart,FnPartiInit,& 27 | target_density,dt_reinit,dt_mld,dt_case,& 28 | Khdiff,Kvdiff,NPP,Npts,output_dir,fn_PHIHYD,fn_MLD,DumpClock,& 29 | #else 30 | namelist /PARAM/ casename,path2uvw,path2grid,& 31 | dt,tend, fn_UVEL, fn_VVEL, fn_WVEL, fn_THETA, fn_SALT, fn_GAMMA,& 32 | pickup,pickupFreq,saveFreq,diagFreq,tstart,FnPartiInit,& 33 | target_density,dt_reinit,dt_mld,dt_case,& 34 | Khdiff,Kvdiff,NPP,Npts,output_dir,fn_PHIHYD,fn_MLD,DumpClock,& 35 | #endif 36 | barrier_north,barrier_south,barrier_east,barrier_west 37 | 38 | 39 | 40 | 41 | 42 | OPEN (UNIT=212, FILE='data.nml') 43 | read (212,NML=PARAM) !from the namelist file 44 | close(212) 45 | 46 | #ifdef isGlider 47 | 48 | OPEN (UNIT=212, FILE='data.glider.nml') 49 | read (212,NML=PARAMG) !from the namelist file 50 | close(212) 51 | 52 | print*, '====', dive_depth,parking_time 53 | 54 | #endif 55 | 56 | #ifdef isArgo 57 | 58 | OPEN (UNIT=212, FILE='data.Argo.nml') 59 | read (212,NML=PARAMA) !from the namelist file 60 | close(212) 61 | #endif 62 | 63 | 64 | end subroutine read_namelist 65 | 66 | 67 | -------------------------------------------------------------------------------- /test/src.mitgcm/dump_data.f90: -------------------------------------------------------------------------------- 1 | subroutine dump_data(IPP) 2 | !output particle data 3 | use omp_lib 4 | use global, only: casename,tt,fn_ids,xyz,tsg,& 5 | Npts,parti_mld,DumpClock,saveTSG,& 6 | useMLD,NPP,output_dir,grad 7 | implicit none 8 | character(len=128) :: fn 9 | character(len=16) :: fn1 10 | integer*8 :: iwrite 11 | integer*8,intent(in) :: IPP 12 | 13 | iwrite=int(tt/DumpClock)+1 14 | 15 | write(fn,"(I10.10)") iwrite 16 | write(fn1,"(I4.4)") IPP 17 | 18 | !$OMP PARALLEL SECTIONS 19 | 20 | 21 | !$OMP SECTION 22 | open(fn_ids(1,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.XYZ.'//trim(fn)//'.data',& 23 | access='direct',form='unformatted', convert='BIG_ENDIAN',recl=3*4*Npts,status='replace') 24 | write(fn_ids(1,IPP),rec=1) real(xyz(:,:,IPP),4) 25 | close(fn_ids(1,IPP)) 26 | 27 | !$OMP SECTION 28 | if (saveTSG) then 29 | open(fn_ids(2,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.TSG.'//trim(fn)//'.data',& 30 | access='direct',form='unformatted',convert='BIG_ENDIAN',recl=4*4*Npts,status='replace') 31 | write(fn_ids(2,IPP),rec=1) real(tsg(:,:,IPP),4) 32 | close(fn_ids(2,IPP)) 33 | endif 34 | 35 | !$OMP SECTION 36 | if (useMLD) then 37 | open(fn_ids(3,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.MLD.'//trim(fn)//'.data',& 38 | access='direct',form='unformatted',convert='BIG_ENDIAN',recl=4*Npts,status='replace') 39 | write(fn_ids(3,IPP),rec=1) real(parti_mld(:,IPP),4) 40 | close(fn_ids(3,IPP)) 41 | endif 42 | ! !$OMP SECTION 43 | ! open(fn_ids(4,IPP),file=trim(output_dir)//'/'//trim(casename)//'_'//trim(fn1)//'.GRAD.'//trim(fn)//'.data',& 44 | ! access='direct',form='unformatted', convert='BIG_ENDIAN',recl=4*4*Npts,status='replace') 45 | ! write(fn_ids(4,IPP),rec=1) real(grad(:,:,IPP),4) 46 | ! close(fn_ids(4,IPP)) 47 | 48 | !$OMP END PARALLEL SECTIONS 49 | 50 | end subroutine dump_data 51 | -------------------------------------------------------------------------------- /src/mixing_mld.f90: -------------------------------------------------------------------------------- 1 | subroutine apply_mixing_mld(IPP) 2 | #include "cpp_options.h" 3 | 4 | #ifdef use_mixedlayer_shuffle 5 | 6 | use global, only: Npts,hFacC,xyz,z2k,k2z,Nx,Ny,dt_mld,tt,mld,& 7 | parti_mld,kvdt2,khdt2,dxg_r,dyg_r,drf_r,pi2f 8 | use random, only: random_normal 9 | implicit none 10 | integer*8 :: i,icount 11 | integer*8 :: ip,jp,kp 12 | real*8 :: num, z, pz 13 | logical :: ivok_mld 14 | integer*8, intent(in) :: IPP 15 | 16 | ivok_mld= (mod(tt,dt_mld) .eq. 0) 17 | 18 | call load_mld(tt) 19 | !where (mld>1000) mld=1000d0 20 | parti_mld=0d0 21 | call random_seed(put=int(pi2f(1:30,1),8)) 22 | 23 | icount=0 24 | !$OMP PARALLEL DO PRIVATE(i,ip,jp,kp,pz,num,z) 25 | do i =1,Npts 26 | if (xyz(i,2,IPP)Nx+1) then 11 | ! xyz(ip,1)=Nx+0.5 12 | !elseif (xyz(ip,1)<-1) then 13 | ! xyz(ip,1)=-0.5 14 | !endif 15 | if (xyz(ip,2,IPP)Nz-0.5) then 18 | ! xyz(ip,3)=Nz-1.5 19 | !elseif (xyz(ip,3)<-1) then 20 | ! xyz(ip,3)=0.0 21 | !endif 22 | 23 | ! pi2f(ip)=floor(xyz(ip,1)) 24 | pi2f(ip,IPP)=floor(x) 25 | pj2f(ip,IPP)=floor(xyz(ip,2,IPP)) 26 | pk2f(ip,IPP)=floor(xyz(ip,3,IPP)) 27 | ! pi2c(ip)=floor(xyz(ip,1)-0.5d0) 28 | pi2c(ip,IPP)=floor(x-0.5d0) 29 | pj2c(ip,IPP)=floor(xyz(ip,2,IPP)-0.5d0) 30 | pk2c(ip,IPP)=floor(xyz(ip,3,IPP)-0.5d0) 31 | 32 | ! dif(ip) = xyz(ip,1)-pi2f(ip) 33 | dif(ip,IPP) = x-pi2f(ip,IPP) 34 | djf(ip,IPP) = xyz(ip,2,IPP)-pj2f(ip,IPP) 35 | dkf(ip,IPP) = xyz(ip,3,IPP)-pk2f(ip,IPP) 36 | 37 | ! dic(ip) = xyz(ip,1)-pi2c(ip)-0.5d0 38 | dic(ip,IPP) = x-pi2c(ip,IPP)-0.5d0 39 | djc(ip,IPP) = xyz(ip,2,IPP)-pj2c(ip,IPP)-0.5d0 40 | dkc(ip,IPP) = xyz(ip,3,IPP)-pk2c(ip,IPP)-0.5d0 41 | 42 | !if (maxval(pj2f(ipts(1):ipts(2)))>321 .or. minval(pj2f(ipts(1):ipts(2)))<-1 ) then 43 | ! print*, "something wrong, maxval(pj2f)" 44 | !endif 45 | ! if (pi2f(ip)>Nx-1 .or. pi2f(ip)<-1) then 46 | ! print*, 'something wrong in pi2f' 47 | ! endif 48 | if (pk2f(ip,IPP)<-2 .or. pk2f(ip,IPP)>41) then 49 | xyz(ip,3,IPP)=mod(abs(xyz(ip,3,IPP)),real(Nz-1,8)) 50 | print*, "something wrong in pk2f",pk2f(ip,IPP),'changed the vertical coordinate to',xyz(ip,3,IPP) 51 | endif 52 | endif 53 | end subroutine find_index 54 | -------------------------------------------------------------------------------- /test/src.mitgcm/c_find_uvw.f90: -------------------------------------------------------------------------------- 1 | subroutine find_particle_uvw(t_amend,ip,IPP,t0,t1,uvw) 2 | 3 | use global, only : Nx,Ny,Nz,Npts,xyz,& 4 | dxg_r,dyg_r,drf_r,dtp,& 5 | uu,vv,ww,hFacC,tsg,theta,salt,& 6 | gam,tt, & 7 | pi2f,pj2f,pk2f,pi2c,pj2c,pk2c, & 8 | dif, djf, dkf, dic, djc, dkc 9 | 10 | implicit none 11 | 12 | real*8, intent(in) :: t_amend 13 | integer*8,intent(in) :: t0,t1,ip,IPP 14 | 15 | real*8,dimension(3),intent(out) :: uvw 16 | 17 | real*8,dimension(3) :: dxyz_fac 18 | integer*8 :: i,j,k 19 | real*8 :: tmp0,tmp1,tamend,deltat 20 | 21 | if (dtp+t_amend>1) then 22 | tamend=0.0 23 | deltat=1d0 24 | else 25 | tamend=t_amend 26 | deltat=dtp+t_amend 27 | endif 28 | 29 | if (xyz(ip,2,IPP)>Ny-1 .or. xyz(ip,2,IPP) < 0) then 30 | uvw=0d0 31 | else 32 | 33 | call find_index(ip,IPP) 34 | 35 | dxyz_fac(1) = dxg_r(pi2f(ip,IPP),pj2c(ip,IPP)) 36 | dxyz_fac(2) = dyg_r(pi2c(ip,IPP),pj2f(ip,IPP)) 37 | dxyz_fac(3) = drf_r(pk2f(ip,IPP)) 38 | 39 | i=pi2f(ip,IPP) 40 | j=pj2c(ip,IPP) 41 | k=pk2c(ip,IPP) 42 | 43 | call interp_trilinear(dif(ip,IPP),djc(ip,IPP),dkc(ip,IPP),& 44 | uu(i:i+1,j:j+1,k:k+1,t0),tmp0) 45 | call interp_trilinear(dif(ip,IPP),djc(ip,IPP),dkc(ip,IPP),& 46 | uu(i:i+1,j:j+1,k:k+1,t1),tmp1) 47 | uvw(1)= (tmp1-tmp0)*deltat + tmp0 48 | 49 | i=pi2c(ip,IPP) 50 | j=pj2f(ip,IPP) 51 | call interp_trilinear(dic(ip,IPP),djf(ip,IPP),dkc(ip,IPP),& 52 | vv(i:i+1,j:j+1,k:k+1,t0),tmp0) 53 | call interp_trilinear(dic(ip,IPP),djf(ip,IPP),dkc(ip,IPP),& 54 | vv(i:i+1,j:j+1,k:k+1,t1),tmp1) 55 | 56 | uvw(2) = (tmp1-tmp0)*deltat + tmp0 57 | 58 | j=pj2c(ip,IPP) 59 | k=pk2f(ip,IPP) 60 | 61 | call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkf(ip,IPP),& 62 | ww(i:i+1,j:j+1,k:k+1,t0),tmp0) 63 | call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkf(ip,IPP),& 64 | ww(i:i+1,j:j+1,k:k+1,t1),tmp1) 65 | 66 | uvw(3) = (-tmp1+tmp0)*deltat - tmp0 !positive velocity points downward 67 | uvw=uvw*dxyz_fac 68 | endif 69 | 70 | end subroutine find_particle_uvw 71 | -------------------------------------------------------------------------------- /src/utils.f90: -------------------------------------------------------------------------------- 1 | 2 | subroutine diag() 3 | use global, only : tsg,xyz,uvwp 4 | implicit none 5 | print*, "=========================================" 6 | print*, "particle diagnoses" 7 | print*, "Temperature maximum = ",maxval(tsg(:,1,:)) 8 | print*, "Temperature minimum = ",minval(tsg(:,1,:)) 9 | print*, "Salinity maximum = ",maxval(tsg(:,2,:)) 10 | print*, "Salinity minimum = ",minval(tsg(:,2,:)) 11 | print*, "Density maximum = ",maxval(tsg(:,3,:)) 12 | print*, "Density minimum = ",minval(tsg(:,3,:)) 13 | print*, "Depth minimum = ",minval(xyz(:,3,:)) 14 | print*, "Depth maximum = ",maxval(xyz(:,3,:)) 15 | print*, "x minimum = ",minval(xyz(:,1,:)) 16 | print*, "x maximum = ",maxval(xyz(:,1,:)) 17 | print*, "y minimum = ",minval(xyz(:,2,:)) 18 | print*, "y maximum = ",maxval(xyz(:,2,:)) 19 | print*, "z minimum = ",minval(xyz(:,3,:)) 20 | print*, "z maximum = ",maxval(xyz(:,3,:)) 21 | print*, "u maximum = ",maxval(uvwp(:,1,:)) 22 | print*, "v maximum = ",maxval(uvwp(:,2,:)) 23 | print*, "w maximum = ",maxval(uvwp(:,3,:)) 24 | 25 | end subroutine diag 26 | 27 | subroutine count_stagnant() 28 | 29 | use global, only : tsg,Npts,NPP 30 | implicit none 31 | integer*8 :: ip,nstag,IPP 32 | nstag=0 33 | 34 | do IPP=1,NPP 35 | do ip=1,Npts 36 | if (tsg(ip,1,IPP) .eq. 0) then 37 | nstag=nstag+1 38 | endif 39 | enddo 40 | enddo 41 | 42 | 43 | print*, "Number of stagnant particles: ", nstag 44 | 45 | end subroutine count_stagnant 46 | 47 | 48 | subroutine read_filenames() 49 | use global, only : Nrecs 50 | implicit none 51 | character(28), dimension(Nrecs,3) :: fns 52 | integer :: i 53 | !read filenames 54 | open(4,file='filelist.u',form='formatted') 55 | open(5,file='filelist.v',form='formatted') 56 | open(6,file='filelist.w',form='formatted') 57 | do i=1,Nrecs 58 | read(4, "(A28)") fns(i,1) 59 | read(5, "(A28)") fns(i,2) 60 | read(6, "(A28)") fns(i,3) 61 | enddo 62 | close(4) 63 | close(5) 64 | close(6) 65 | end subroutine read_filenames 66 | 67 | 68 | -------------------------------------------------------------------------------- /src/open_files.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE open_files() 2 | #include "cpp_options.h" 3 | 4 | USE global,ONLY:fn_uvwtsg_ids,fn_ids,fn_id_mld,path2uvw,fn_UVEL,& 5 | fn_VVEL,fn_WVEL,fn_THETA,fn_SALT,fn_GAMMA,fn_PHIHYD,& 6 | #ifdef isArgo 7 | save_argo_FnID,& 8 | #endif 9 | Nx,Ny,Nz,fn_MLD,casename,output_dir 10 | 11 | IMPLICIT NONE 12 | INTEGER*8 :: i 13 | CHARACTER(len=6) :: fnip 14 | CHARACTER(len=3) :: fnipp 15 | 16 | #ifndef one_file_per_step 17 | 18 | OPEN(fn_uvwtsg_ids(1),file=TRIM(path2uvw)//TRIM(fn_UVEL),& 19 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 20 | status='old',recl=4*Nx*Ny) 21 | OPEN(fn_uvwtsg_ids(2),file=TRIM(path2uvw)//TRIM(fn_VVEL),& 22 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 23 | status='old',recl=4*Nx*Ny) 24 | 25 | 26 | OPEN(fn_uvwtsg_ids(3),file=TRIM(path2uvw)//TRIM(fn_WVEL),& 27 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 28 | status='old',recl=4*Nx*Ny) 29 | 30 | 31 | 32 | IF (TRIM(fn_PHIHYD) .NE. '') THEN 33 | OPEN(fn_uvwtsg_ids(7),file=TRIM(path2uvw)//TRIM(fn_PHIHYD),& 34 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 35 | status='old',recl=4*Nx*Ny) 36 | ENDIF 37 | 38 | OPEN(fn_uvwtsg_ids(4),file=TRIM(path2uvw)//TRIM(fn_THETA),& 39 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 40 | status='old',recl=4*Nx*Ny) 41 | OPEN(fn_uvwtsg_ids(5),file=TRIM(path2uvw)//TRIM(fn_SALT),& 42 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 43 | status='old',recl=4*Nx*Ny) 44 | IF (TRIM(fn_GAMMA) .NE. '') THEN 45 | OPEN(fn_uvwtsg_ids(6),file=TRIM(path2uvw)//TRIM(fn_GAMMA),& 46 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 47 | status='old',recl=4*Nx*Ny) 48 | ENDIF 49 | 50 | 51 | #ifdef use_mixedlayer_shuffle 52 | OPEN(fn_id_mld,file=TRIM(path2uvw)//TRIM(fn_MLD),& 53 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 54 | status='old',recl=4*Nx*Ny) 55 | #endif 56 | 57 | #endif 58 | 59 | 60 | #ifdef isArgo 61 | save_argo_FnID=1111 62 | open(save_argo_FnID,file=TRIM(output_dir)//'/'//TRIM(casename)//'.argo.surface.XYZ.data',& 63 | form='formatted',access='append',status='new') 64 | #endif 65 | 66 | 67 | END SUBROUTINE open_files 68 | -------------------------------------------------------------------------------- /test/src.mitgcm/driver_omp.f90: -------------------------------------------------------------------------------- 1 | program main 2 | !#include "cppdefs.f90" 3 | use global 4 | use omp_lib 5 | 6 | implicit none 7 | integer*8 :: n_threads=16 8 | integer*8 :: i,IPP,SNPP 9 | !integer*8, dimension(2) :: ipts 10 | character(len=10) :: date,time0,time1,zone 11 | integer*8,dimension(8):: time 12 | 13 | CALL DATE_AND_TIME(date,time0,zone,time) 14 | 15 | call omp_set_num_threads(n_threads) 16 | call read_namelist() 17 | call allocate_parti() 18 | 19 | call calc_parameters() 20 | 21 | call open_files() 22 | 23 | ! load z to k lookup table for mixed layer process 24 | if (useMLD) then 25 | call load_z_lookup_table() 26 | endif 27 | 28 | call load_grid() 29 | 30 | call load_reflect() 31 | 32 | 33 | ! call open_files() 34 | ! initilize particles on neutral density surfaces 35 | print*, "=================================================" 36 | print*, "initializing particles ......... " 37 | 38 | do IPP = 1, NPP 39 | call init_particles(IPP) 40 | enddo 41 | call load_uvwtsg(rec_num,0) 42 | call load_uvwtsg(rec_num+1,1) 43 | iswitch=1 44 | do while (tt<=tend) 45 | SNPP = min(int(tt/dt_case)+1,NPP) 46 | if ( mod(tt,dt_case)==0 .and. int(tt/dt_case,8)+1<=NPP) then 47 | call init_particles(SNPP) 48 | endif 49 | 50 | do i=1,int(dt_file/dt) 51 | !CALL DATE_AND_TIME(date,time,zone,time0) 52 | dtp = real(mod(tt,dt_file))/real(dt_file) 53 | call rk4(SNPP) 54 | tt=tt+dt 55 | enddo 56 | 57 | if (mod(rec_num,Nrecs)==0) then 58 | call load_uvwtsg(1,0) 59 | call load_uvwtsg(2,1) 60 | rec_num=rec_num+2 61 | do IPP=1,SNPP 62 | call jump(IPP) 63 | enddo 64 | iswitch=1 65 | else 66 | rec_num=rec_num+1 67 | iswitch=abs(iswitch-1) 68 | print*, iswitch 69 | call load_uvwtsg(rec_num,iswitch) 70 | endif 71 | 72 | call check_and_dump(SNPP) 73 | print*, tsg(1,1,1) 74 | enddo 75 | CALL DATE_AND_TIME(date,time1,zone,time) 76 | print*, "Program started at", time0, "and ended ", time1 77 | call close_files() 78 | 79 | end program main 80 | 81 | -------------------------------------------------------------------------------- /src/apply_jump.f90: -------------------------------------------------------------------------------- 1 | subroutine jump(IPP) 2 | !introduce an artificial jump in z to enforce a constant density 3 | 4 | use global, only: Npts, xyz, tsg,Nx,Ny, Nz,gam,hFacC,pi2f,pj2f,pk2c 5 | 6 | implicit none 7 | 8 | integer*8, intent(in) :: IPP 9 | integer*8 :: i,ip,k 10 | real*8, dimension(-1:Nz) :: gam1d 11 | integer*8 :: i1,j1,k1 12 | real*8 :: maxgam 13 | 14 | print*, "apply jumping condition at the looping transition" 15 | print*, "gamma min and max are ", maxval(gam), minval(gam) 16 | print*, "mean z", sum(xyz(:,3,IPP))/Npts 17 | print*, "mean gamma ", sum(tsg(:,3,IPP))/Npts 18 | 19 | !$OMP PARALLEL DO PRIVATE(ip,i1,j1,k1,gam1d,maxgam,k,i) SCHEDULE(dynamic) 20 | do ip = 1, Npts 21 | if (xyz(ip,2,IPP)<=Ny-1) then 22 | i1=pi2f(ip,IPP) 23 | j1=pj2f(ip,IPP) 24 | k1=pk2c(ip,IPP) 25 | if (hFacC(i1,j1,k1) .eq. 1 .and. gam(i1,j1,k1,0) .gt. 10) then 26 | !gam1d1 = (gamma1(i1+1,j1,:)-gamma1(i1,j1,:))*(xyz(ip,1)-ixyz(ip,1))+gamma1(i1,j1,:) 27 | !gam1d2 = (gamma1(i1+1,j1+1,:)-gamma1(i1,j1+1,:))*(xyz(ip,1)-ixyz(ip,1))+gamma1(i1,j1+1,:) 28 | !gam1d = (gam1d2-gam1d1)*(xyz(ip,2)-j1)+gam1d1 29 | gam1d = gam(i1,j1,:,0) 30 | maxgam = maxval(gam1d) 31 | where(gam1d==20) gam1d=maxgam 32 | 33 | if ( tsg(ip,3,IPP) < gam1d(0) ) then 34 | xyz(ip,3,IPP) = 0.5d0 35 | elseif ( tsg(ip,3,IPP) > maxgam ) then 36 | xyz(ip,3,IPP) = xyz(ip,3,IPP) 37 | else 38 | k=0 39 | i=1 40 | do while ( tsg(ip,3,IPP) > gam1d(k) ) 41 | k=k+1 42 | enddo 43 | 44 | xyz(ip,3,IPP) = real(k-1,8)+(tsg(ip,3,IPP)-gam1d(k-1))/(gam1d(k)-gam1d(k-1))+0.5d0 45 | if (xyz(ip,3,IPP)/=xyz(ip,3,IPP)) then 46 | print*, 'k,xyz,tsg(ip,3),gam1d(k-1),',k,xyz(ip,3,IPP),tsg(ip,3,IPP),gam1d(k-1) 47 | endif 48 | endif 49 | endif 50 | endif 51 | enddo 52 | !$OMP END PARALLEL DO 53 | ! print*, "gamma min and max are ", maxval(gam), minval(gam) 54 | ! print*, "mean z", sum(xyz(:,3,IPP))/Npts 55 | ! print*, "mean gamma ", sum(tsg(:,3,IPP))/Npts 56 | 57 | end subroutine jump 58 | -------------------------------------------------------------------------------- /test/src.mitgcm/c_loop_jump.f90: -------------------------------------------------------------------------------- 1 | subroutine jump(IPP) 2 | !introduce an artificial jump in z to enforce a constant density 3 | 4 | use global, only: Npts, xyz, tsg,Nx,Ny, Nz,gam,hFacC,pi2f,pj2f,pk2c 5 | 6 | implicit none 7 | 8 | integer*8, intent(in) :: IPP 9 | integer*8 :: i,ip,k 10 | real*8, dimension(-1:Nz) :: gam1d 11 | integer*8 :: i1,j1,k1 12 | real*8 :: maxgam 13 | 14 | print*, "apply jumping condition at the looping transition" 15 | print*, "gamma min and max are ", maxval(gam), minval(gam) 16 | print*, "mean z", sum(xyz(:,3,IPP))/Npts 17 | print*, "mean gamma ", sum(tsg(:,3,IPP))/Npts 18 | 19 | !$OMP PARALLEL DO PRIVATE(ip,i1,j1,k1,gam1d,maxgam,k,i) SCHEDULE(dynamic) 20 | do ip = 1, Npts 21 | if (xyz(ip,2,IPP)<=Ny-1) then 22 | i1=pi2f(ip,IPP) 23 | j1=pj2f(ip,IPP) 24 | k1=pk2c(ip,IPP) 25 | if (hFacC(i1,j1,k1) .eq. 1 .and. gam(i1,j1,k1,0) .gt. 10) then 26 | !gam1d1 = (gamma1(i1+1,j1,:)-gamma1(i1,j1,:))*(xyz(ip,1)-ixyz(ip,1))+gamma1(i1,j1,:) 27 | !gam1d2 = (gamma1(i1+1,j1+1,:)-gamma1(i1,j1+1,:))*(xyz(ip,1)-ixyz(ip,1))+gamma1(i1,j1+1,:) 28 | !gam1d = (gam1d2-gam1d1)*(xyz(ip,2)-j1)+gam1d1 29 | gam1d = gam(i1,j1,:,0) 30 | maxgam = maxval(gam1d) 31 | where(gam1d==20) gam1d=maxgam 32 | 33 | if ( tsg(ip,3,IPP) < gam1d(0) ) then 34 | xyz(ip,3,IPP) = 0.5d0 35 | elseif ( tsg(ip,3,IPP) > maxgam ) then 36 | xyz(ip,3,IPP) = xyz(ip,3,IPP) 37 | else 38 | k=0 39 | i=1 40 | do while ( tsg(ip,3,IPP) > gam1d(k) ) 41 | k=k+1 42 | enddo 43 | 44 | xyz(ip,3,IPP) = real(k-1,8)+(tsg(ip,3,IPP)-gam1d(k-1))/(gam1d(k)-gam1d(k-1))+0.5d0 45 | if (xyz(ip,3,IPP)/=xyz(ip,3,IPP)) then 46 | print*, 'k,xyz,tsg(ip,3),gam1d(k-1),',k,xyz(ip,3,IPP),tsg(ip,3,IPP),gam1d(k-1) 47 | endif 48 | endif 49 | endif 50 | endif 51 | enddo 52 | !$OMP END PARALLEL DO 53 | ! print*, "gamma min and max are ", maxval(gam), minval(gam) 54 | ! print*, "mean z", sum(xyz(:,3,IPP))/Npts 55 | ! print*, "mean gamma ", sum(tsg(:,3,IPP))/Npts 56 | 57 | end subroutine jump 58 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # ============================================================================ 2 | # Name : Makefile 3 | # Author : Jinbo Wang 4 | # Version : 1.0 5 | # Copyright : MIT License 6 | # Description : Lagrangian integration 7 | # ============================================================================ 8 | 9 | objects = global.o allocate_vars.o interp_tracer.o \ 10 | random.o driver_omp.o io.o get_particle_index.o \ 11 | get_velocity.o rk4.o interp_trilinear.o \ 12 | apply_jump.o init_particles.o mixing.o read_namelist.o \ 13 | apply_boundaryCondition.o utils.o c_filenames.o read_pickup.o\ 14 | save_pickup.o load_reflect.o load_depth.o mixing_mld.o\ 15 | check_and_save.o calc_parameters.o get_glider_velocity.o\ 16 | calc_gradient.o interp_bilinear.o set_file_ids.o 17 | 18 | obj_argo = global.o allocate_vars.o \ 19 | random.o driver_omp.o io.o get_particle_index.o \ 20 | get_velocity.o rk4.o interp_trilinear.o \ 21 | init_particles.o mixing.o read_namelist.o \ 22 | utils.o open_files.o close_files.o read_pickup.o\ 23 | save_pickup.o load_depth.o c_filenames.o \ 24 | check_and_save.o calc_parameters.o interp_bilinear.o\ 25 | get_argo_w.o set_file_ids.o 26 | 27 | obj_glider= global.o allocate_vars.o interp_tracer.o \ 28 | random.o driver_omp.o io.o get_particle_index.o \ 29 | get_velocity.o rk4.o interp_trilinear.o \ 30 | apply_jump.o init_particles.o mixing.o read_namelist.o \ 31 | apply_boundaryCondition.o utils.o open_files.o close_files.o read_pickup.o\ 32 | save_pickup.o load_reflect.o load_depth.o mixing_mld.o c_filenames.o \ 33 | check_and_save.o calc_parameters.o calc_gradient.o interp_bilinear.o\ 34 | get_glider_velocity.o set_file_ids.o 35 | 36 | FORTRAN_COMPILER = gfortran 37 | 38 | #FFLAGS = -x f95-cpp-input -Wall -fopenmp -O3 -mcmodel=large -fdefault-integer-8 -fdefault-real-8 39 | FFLAGS = -x f95-cpp-input -fopenmp -O3 -mcmodel=medium -fdefault-integer-8 -fdefault-real-8 40 | 41 | opt: $(objects); $(FORTRAN_COMPILER) -o O.particle -fopenmp $(objects) 42 | 43 | argo: $(obj_argo); $(FORTRAN_COMPILER) -o O.argo -fopenmp $(obj_argo) 44 | 45 | glider: $(obj_glider); $(FORTRAN_COMPILER) -o O.glider -fopenmp $(obj_glider) 46 | 47 | %.o: %.f90; $(FORTRAN_COMPILER) ${FFLAGS} -c $< 48 | 49 | clean: 50 | rm *.o *.mod 51 | -------------------------------------------------------------------------------- /src/rk4.f90: -------------------------------------------------------------------------------- 1 | subroutine rk4(SNPP) 2 | #include "cpp_options.h" 3 | 4 | ! integrate in time using RK4 scheme 5 | #ifdef isGlider 6 | use global, only : tt,Npts,iswitch,xyz,dt,Nx,Ny,Nz,glider_clock,& 7 | #endif 8 | #ifdef isArgo 9 | use global, only : tt,Npts,iswitch,xyz,dt,Nx,Ny,Nz,argo_clock,& 10 | #endif 11 | #ifndef isArgo 12 | #ifndef isGlider 13 | use global, only : tt,Npts,iswitch,xyz,dt,Nx,Ny,Nz,& 14 | #endif 15 | #endif 16 | uvwp,dt_file,t_amend 17 | implicit none 18 | real*8, dimension(3) :: x0,x1,uvw 19 | integer*8 :: t0,t1,ip,IPP 20 | integer*8, intent(in) :: SNPP 21 | 22 | t0=abs(iswitch-1) 23 | t1=iswitch 24 | do IPP=1,SNPP 25 | 26 | #ifdef isGlider 27 | !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(x0,x1,uvw,ip) SHARED(glider_clock,IPP,SNPP,Npts,xyz,t_amend,t0,t1,dt) 28 | #endif 29 | #ifdef isArgo 30 | !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(x0,x1,uvw,ip) SHARED(argo_clock,IPP,SNPP,Npts,xyz,t_amend,t0,t1,dt) 31 | #endif 32 | #ifndef isGlider 33 | #ifndef isArgo 34 | !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(x0,x1,uvw,ip) SHARED(IPP,SNPP,Npts,xyz,t_amend,t0,t1,dt) 35 | #endif 36 | #endif 37 | 38 | do ip=1,Npts 39 | 40 | x0=xyz(ip,:,IPP) 41 | x1=xyz(ip,:,IPP) 42 | 43 | call find_particle_uvw(0.0,ip,IPP,t0,t1,uvw) 44 | x1=x1+dt*uvw/6.0 45 | xyz(ip,:,IPP)=x0+dt*uvw/2.0 46 | 47 | call find_particle_uvw(t_amend,ip,IPP,t0,t1,uvw) 48 | x1=x1+dt*uvw/3.0 49 | xyz(ip,:,IPP)=x0+dt*uvw/2.0 50 | 51 | call find_particle_uvw(t_amend,ip,IPP,t0,t1,uvw) 52 | x1=x1+dt*uvw/3.0 53 | xyz(ip,:,IPP)=x0+dt*uvw 54 | 55 | call find_particle_uvw(t_amend*2.0,ip,IPP,t0,t1,uvw) 56 | xyz(ip,:,IPP)=x1+dt*uvw/6.0 57 | 58 | #ifdef isArgo 59 | argo_clock(ip,2,IPP)=argo_clock(ip,2,IPP)+dt 60 | #endif 61 | #ifdef isGlider 62 | glider_clock(ip,2,IPP)=glider_clock(ip,2,IPP)+dt 63 | #endif 64 | 65 | enddo 66 | 67 | !$OMP END PARALLEL DO 68 | 69 | #ifdef use_Laplacian_diffusion 70 | call apply_Laplacian_diffusion(IPP) 71 | #endif 72 | 73 | #ifdef use_mixedlayer_shuffle 74 | call apply_mixing_mld(IPP) 75 | #endif 76 | 77 | #ifdef reflective_continent 78 | call set_boundary(IPP) 79 | #endif 80 | 81 | !if (ip==1) then 82 | ! print*, "=====",xyz(1,:,1) 83 | !endif 84 | 85 | 86 | enddo 87 | 88 | end subroutine rk4 89 | -------------------------------------------------------------------------------- /test/src.mitgcm/interp_tracer.f90: -------------------------------------------------------------------------------- 1 | 2 | subroutine interp_tracer(t0,t1,IPP) 3 | use global,only: Nx,Ny,dtp,xyz,dic,djc,dkc,pi2c,pj2c,pk2c,Npts,theta,salt,gam,tsg,NPP,tt,phihyd,fn_PHIHYD 4 | implicit none 5 | integer*8,intent(in) :: t0,t1,IPP 6 | integer*8 :: i,j,k,ip 7 | real*8 :: tmp0,tmp1 8 | real*4 :: tmp(2,2,2) 9 | 10 | if (trim(fn_PHIHYD) .ne. '') then 11 | call load_PHIHYD(tt) 12 | endif 13 | 14 | !$OMP PARALLEL DO PRIVATE(ip,i,j,k,tmp0,tmp1) SHARED(IPP,t0,t1,dic,djc,dkc,theta,salt,gam,tsg,dtp,phihyd) SCHEDULE(dynamic) 15 | do ip=1,npts 16 | 17 | if (xyz(ip,2,IPP)1000) mld=1000d0 21 | parti_mld=0d0 22 | call random_seed(put=int(pi2f(1:30,1),8)) 23 | 24 | icount=0 25 | !$OMP PARALLEL DO PRIVATE(i,ip,jp,kp,pz,num,z) 26 | do i =1,Npts 27 | if (xyz(i,2,IPP)1) then 30 | tamend=0.0 31 | deltat=1d0 32 | else 33 | tamend=t_amend 34 | deltat=dtp+t_amend 35 | endif 36 | 37 | #ifdef barrier_lon 38 | if (xyz(ip,1,IPP)>barrier_east .or. xyz(ip,1,IPP)barrier_north .or. xyz(ip,2,IPP)4 .or. abs(xyz(ip,3,IPP))>Nz+2 ) then 94 | print*, 'particle velocity',uvw 95 | print*, 'particle positions',ip,ip, xyz(ip,:,IPP) 96 | stop "particle velocity exceeds 4m/s. It is obviously wrong somewhere. This error message is generated by get_velocity.f90" 97 | endif 98 | 99 | 100 | #ifdef isGlider 101 | uvwp(ip,:,IPP)=uvw 102 | uvw=(uvw+uvw_g)*dxyz_fac 103 | !uvw(3)=uvw_g(3)*dxyz_fac(3) 104 | #else 105 | uvwp(ip,:,IPP)=uvw 106 | uvw=uvw*dxyz_fac 107 | #endif 108 | 109 | 110 | #ifdef barrier_lat 111 | endif 112 | #endif 113 | 114 | #ifdef barrier_lon 115 | endif 116 | #endif 117 | 118 | end subroutine find_particle_uvw 119 | -------------------------------------------------------------------------------- /src/interp_tracer.f90: -------------------------------------------------------------------------------- 1 | subroutine interp_tracer(t0,t1,IPP) 2 | use global 3 | !,only: Nx,Ny,dtp,xyz,dic,djc,dkc,pi2c,pj2c,pk2c,Npts,theta,salt,gam,tsg,NPP,tt,phihyd,fn_PHIHYD 4 | implicit none 5 | integer*8,intent(in) :: t0,t1,IPP 6 | integer*8 :: i,j,k,ip 7 | real*8 :: tmp0,tmp1 8 | #ifdef isGlider 9 | real*4 :: tmp(2,2) 10 | #else 11 | real*4 :: tmp(2,2,2) 12 | #endif 13 | 14 | if (trim(fn_PHIHYD) .ne. '') then 15 | call load_PHIHYD(tt) 16 | endif 17 | 18 | #ifdef isGlider 19 | 20 | !$OMP PARALLEL DO PRIVATE(ip,i,j,k,tmp0,tmp1) SHARED(IPP,t0,t1,dic,djc,dkc,theta,salt,gam,tsg,dtp,phihyd) SCHEDULE(dynamic) 21 | do ip=1,npts 22 | 23 | if (xyz(ip,2,IPP) 9 | Scripps Institution of Oceanography 10 | August 26, 2015 11 | 12 | """ 13 | import numpy as np 14 | import scipy as sp 15 | import pylab as plt 16 | import os,sys 17 | from scipy import interpolate 18 | 19 | def reflective_boundary(): 20 | from scipy.interpolate import NearestNDInterpolator as npi 21 | 22 | 23 | 24 | fn_hFacC=pth_data_in+'hFacC.data' 25 | try: 26 | hfac=np.fromfile(fn_hFacC,'>f4').reshape(nz,ny,nx) 27 | except: 28 | sys.exit(' ^o^ '*20+'\n%s does not exist, please double check.\n'%fn_hFacC+ 29 | ' ^p^ '*20) 30 | 31 | 32 | 33 | y=np.arange(ny) 34 | x=np.arange(-10,nx+10) 35 | xx,yy=np.meshgrid(x,y) 36 | xs=xx.flatten() 37 | ys=yy.flatten() 38 | 39 | newx=np.zeros((nz,ny,nx+20)) 40 | newy=np.zeros((nz,ny,nx+20)) 41 | 42 | for k in np.arange(nz): 43 | print("calculating reflective boundary condition for model level",k) 44 | hfc=hfac[k,...] 45 | hf=np.c_[hfc[:,-10:],hfc,hfc[:,:10]] 46 | ip=(hf.flatten()>0) 47 | px = npi((xs[ip],ys[ip]),xs[ip]) 48 | py = npi((xs[ip],ys[ip]),ys[ip]) 49 | newx[k,...]=(px((xx,yy)).reshape(ny,-1))#[:,1:-1] 50 | newy[k,...]=(py((xx,yy)).reshape(ny,-1))#[:,1:-1] 51 | del hfc, hf, ip, py, px 52 | 53 | newx[...,8:-8].astype('>f4').tofile(pth_data_out+'/reflect_x.bin') 54 | newy[...,8:-8].astype('>f4').tofile(pth_data_out+'/reflect_y.bin') 55 | print("+"*40) 56 | print(" Saved files reflect_x.bin reflect_y.bin to %s "%pth_data_out) 57 | print("+"*40) 58 | 59 | return 60 | 61 | def z2kbin(saveplot=False): 62 | 63 | #edit fn_RF to point to the correct RF.data 64 | fn_RF=pth_data_in+'RF.data' 65 | try: 66 | z=np.fromfile(fn_RF,'>f4') 67 | print("There are %i values in RF.data"%z.size) 68 | except: 69 | sys.exit(' ^o^ '*20+'%s does not exist, please double check.'%fn_RF+ 70 | ' ^p^ '*20) 71 | 72 | z=abs(z) 73 | 74 | ff=interpolate.interp1d(z,np.linspace(0,nz,nz+1),'linear', 75 | bounds_error=False,fill_value=nz) 76 | newz = ff(np.arange(6500)) 77 | newz.astype('>f4').tofile(pth_data_out+'z_to_k_lookup_table.bin') 78 | 79 | if saveplot: 80 | plt.plot(np.linspace(0,nz,nz+1),z,'o') 81 | plt.plot(newz,np.arange(6500),'-') 82 | plt.savefig(pth_data_out+'z_to_k_lookup_table.bin.png') 83 | return 84 | 85 | def k2zbin(saveplot=False): 86 | 87 | #edit fn_RF to point to the correct RF.data 88 | fn_RF=pth_data_in+'RF.data' 89 | try: 90 | z=np.fromfile(fn_RF,'>f4') 91 | except: 92 | sys.exit(' ^o^ '*20+'%s does not exist, please double check.'%fn_RF+ 93 | ' ^p^ '*20) 94 | 95 | z=abs(z) 96 | ff=interpolate.interp1d(np.linspace(0,nz,nz+1),z,'linear') 97 | newz = ff(np.linspace(0,nz,nz*10+1)) 98 | newz.astype('>f4').tofile(pth_data_out+'k_to_z_lookup_table.bin') 99 | if saveplot: 100 | plt.plot(np.linspace(0,nz,nz+1),z,'o') 101 | plt.plot(np.linspace(0,nz,nz*10+1),newz,'-') 102 | plt.savefig(pth_data_out+'k_to_z_lookup_table.bin.png') 103 | return 104 | 105 | def check_folder_existence(): 106 | if not os.path.exists(pth_data_out): 107 | os.popen('mkdir %s'%pth_data_out) 108 | print("%s does not exist, just created it for you."%pth_data_out) 109 | if not os.path.exists(pth_data_in): 110 | sys.exit('%s does not exist, please double check.'%pth_data_in) 111 | return 112 | 113 | if __name__=='__main__': 114 | '''change pth_data_out and pth_data_in according to your system, 115 | run the program using "python gen_data.py" ''' 116 | 117 | nz,ny,nx=104,1024,1801 #the model grid size 118 | 119 | pth_data_out='/home/jiw097/sose.grid/' 120 | 121 | #path to MITgcm grid data, i.e., DXG.data,DYG.data etc. 122 | #this script will look for hFacC.data and RF.data in this folder to 123 | #generate necessary binary files for Ocotpus 124 | 125 | pth_data_in='/home/jiw097/sose.grid/' 126 | 127 | check_folder_existence() 128 | 129 | #generate reflect_x.bin and reflect_y.bin 130 | # reflective_boundary() 131 | 132 | #generate k_to_z_lookup_table.bin and 133 | k2zbin() 134 | #generate z_to_k_lookup_table.bin and 135 | z2kbin() 136 | 137 | -------------------------------------------------------------------------------- /src/get_glider_velocity.f90: -------------------------------------------------------------------------------- 1 | subroutine get_glider_velocity(uvw_g,ip,IPP) 2 | #include "cpp_options.h" 3 | 4 | #ifdef isGlider 5 | use global, only : tt,dt,xyz,glider_clock,glider_position,& 6 | parking_time,surfacing_time,SNPP,& 7 | dive_depth,save_glider_FnIDs,glider_cycle,& 8 | output_dir,glider_uv,glider_angle,absv 9 | !add noise to the vertical velocity 10 | !call random_number(tmp0) 11 | !tmp0=(tmp0-0.5)*0.05 12 | 13 | implicit none 14 | 15 | integer*8,intent(in) :: ip, IPP 16 | real*8,dimension(3), intent(out) :: uvw_g 17 | character*6 :: id_str,cycle_str,IPP_str 18 | character(len=255) :: glider_fn 19 | 20 | integer*8 :: i 21 | real*8 :: i0,i1,j0,j1,dx,dy,glider_direction,& 22 | ia,angle,gu,gw,dist 23 | 24 | angle=glider_angle(ip,IPP) 25 | gw=absv*sin(angle/180.0*3.1415926) 26 | gu=absv*cos(angle/180.0*3.1415926) 27 | 28 | ia=glider_clock(ip,1,IPP) 29 | 30 | if ( ia==0 ) then 31 | 32 | !- set horizontal velocity 33 | !- set the glider horizontal velocity depending on the direction 34 | !- relative to the target position 35 | 36 | i0=glider_position(ip,1,IPP) !- old position 37 | j0=glider_position(ip,2,IPP) !- old position 38 | 39 | i1=glider_position(ip,3,IPP) !- target position 40 | j1=glider_position(ip,4,IPP) !- target position 41 | 42 | 43 | #if dive_angle==adjustable 44 | dist=sqrt((real(i1-i0,8))**2+(real(j1-j0,8))**2) 45 | if (dist>3) then 46 | glider_angle(ip,IPP)=30.0 47 | else 48 | glider_angle(ip,IPP)=60.0 49 | endif 50 | gw=absv*sin(angle/180.0*3.1415926) 51 | gu=absv*cos(angle/180.0*3.1415926) 52 | #else 53 | glider_angle(ip,IPP)=60.0 54 | gw=absv*sin(angle/180.0*3.1415926) 55 | gu=absv*cos(angle/180.0*3.1415926) 56 | #endif 57 | 58 | glider_direction=atan(real(abs(j1-j0))/real(abs(i1-i0))) 59 | 60 | glider_uv(ip,1,IPP)=gu * sign( cos(glider_direction), i1-i0) 61 | glider_uv(ip,2,IPP)=gu * sign( sin(glider_direction), j1-j0) 62 | 63 | !ia=0 indicates the instrument is at surface 64 | !save the position and start to descend 65 | 66 | glider_clock(ip,1,IPP)=1 67 | uvw_g(3) = gw 68 | 69 | ! do i=1, SNPP 70 | ! call save_data(SNPP) 71 | ! enddo 72 | 73 | elseif (ia==1) then 74 | !descending 75 | !stay at the bottom after hitting the bottom 76 | if (xyz(ip,3,IPP)spend the parking time 88 | if (glider_clock(ip,2,IPP) .le. parking_time) then 89 | uvw_g(3) = 0.0 !glider_w(3) 90 | glider_clock(ip,2,IPP)=glider_clock(ip,2,IPP)+dt/4.0 91 | else !-> ascend 92 | glider_clock(ip,2,IPP) = 0.0 93 | glider_clock(ip,1,IPP) = 3.0 94 | uvw_g(3) = -1*gw 95 | endif 96 | 97 | elseif (ia==3.0) then 98 | !up from max depth 99 | if ( xyz(ip,3,IPP) > 0) then 100 | uvw_g(3) = -1*gw 101 | else 102 | !reach the surface 103 | !xyz(ip,3,IPP)=0.0 104 | uvw_g(3) = 0.0 105 | glider_clock(ip,1,IPP) = 4.0 106 | glider_clock(ip,2,IPP) =0.0 107 | 108 | endif 109 | 110 | elseif (ia==4.0) then 111 | if (glider_clock(ip,2,IPP) .le. surfacing_time) then 112 | uvw_g(3) = 0.0 !glider_w(3) 113 | glider_clock(ip,2,IPP)=glider_clock(ip,2,IPP)+dt/4.0 114 | else 115 | glider_clock(ip,1,IPP) = 0 116 | glider_clock(ip,2,IPP) =0.0 117 | 118 | !==> save the glider position at the surface 119 | glider_position(ip,1,IPP)=xyz(ip,1,IPP) 120 | glider_position(ip,2,IPP)=xyz(ip,2,IPP) 121 | 122 | !==> close data file 123 | close(save_glider_FnIDs(ip,IPP)) 124 | 125 | !==> reopen new data file 126 | 127 | glider_cycle(ip,IPP)=glider_cycle(ip,IPP)+1 128 | write(id_str,"(I6.6)") ip 129 | write(IPP_str,"(I6.6)") IPP 130 | write(cycle_str,"(I6.6)") glider_cycle(ip,IPP) 131 | 132 | glider_fn=trim(output_dir)//"G.IPP."//IPP_str//".ip."//id_str//".cycle."//trim(cycle_str)//".data" 133 | 134 | open(save_glider_FnIDs(ip,IPP),file=trim(glider_fn),& 135 | form='formatted',access='append',& 136 | status='new') 137 | uvw_g(3) = gw 138 | endif 139 | 140 | endif 141 | 142 | uvw_g(1:2)=glider_uv(ip,:,IPP) 143 | #endif 144 | 145 | end subroutine get_glider_velocity 146 | -------------------------------------------------------------------------------- /src/driver_omp.f90: -------------------------------------------------------------------------------- 1 | program main 2 | 3 | #include "cpp_options.h" 4 | use global 5 | use omp_lib 6 | 7 | implicit none 8 | integer*8 :: n_threads=1 9 | integer*8 :: i,IPP 10 | character(len=10) :: date,time0,time1,zone 11 | character(len=6) :: id_str,IPP_str 12 | character(len=255) :: glider_fn,argo_fn 13 | integer*8,dimension(8):: time 14 | 15 | CALL DATE_AND_TIME(date,time0,zone,time) 16 | 17 | call omp_set_num_threads(n_threads) 18 | call read_namelist() 19 | 20 | call allocate_parti() 21 | 22 | call calc_parameters() 23 | 24 | call c_filenames() 25 | 26 | 27 | ! load z to k lookup table for mixed layer process 28 | call load_z_lookup_table() 29 | 30 | call load_grid() 31 | 32 | ! The reflective boundary use a ad-hoc algorithm to expell particles that enter the continent. 33 | ! This can happen if the time step is large. 34 | 35 | #ifndef isArgo 36 | call load_reflect() 37 | #endif 38 | 39 | 40 | ! initilize particles on neutral density surfaces 41 | print*, "=================================================" 42 | print*, "initializing particles ......... " 43 | 44 | 45 | do IPP = 1, NPP 46 | call init_particles(IPP) 47 | 48 | #ifdef isGlider 49 | do i=1,Npts 50 | write(id_str,"(I6.6)") i 51 | write(IPP_str,"(I6.6)") IPP 52 | glider_fn=trim(output_dir)//"G.IPP."//IPP_str//".ip."//id_str//".cycle.000000.data" 53 | open(save_glider_FnIDs(i,IPP),file=trim(glider_fn),& 54 | form='formatted',access='sequential',& 55 | status='new') 56 | enddo 57 | #endif 58 | 59 | #ifdef isArgo 60 | do i=1,Npts 61 | write(id_str,"(I6.6)") i 62 | write(IPP_str,"(I6.6)") IPP 63 | argo_fn=trim(output_dir)//"A.IPP."//IPP_str//".ip."//id_str//".surfaceLoc.data" 64 | !OPEN(save_argo_FnIDs(i,IPP),file=TRIM(argo_fn),& 65 | ! access='sequential',form='unformatted', convert='BIG_ENDIAN',status='unknown') 66 | 67 | OPEN(save_argo_FnIDs(i,IPP),file=TRIM(argo_fn)) 68 | #ifdef saveArgoProfile 69 | OPEN(save_argo_profileIDs(i,IPP),file=trim(output_dir)//"A.IPP."//IPP_str//".ip."//id_str//".profiles.data",& 70 | access='direct',form='unformatted', recl=6*4*4,convert='BIG_ENDIAN',status='unknown') 71 | #endif 72 | 73 | WRITE(save_argo_FnIDs(i,IPP),*) real(0.0,4),REAL(xyz(i,:,IPP),4) 74 | 75 | enddo 76 | #endif 77 | 78 | enddo 79 | 80 | if (pickup>0) then 81 | call read_pickup() 82 | call load_uvw(marker(1),marker(2)) 83 | call load_uvw(marker(1)+1,abs(1-marker(2))) 84 | else 85 | iswitch=1 86 | call check_and_save(NPP) 87 | !load the first two time steps 88 | call load_uvw(1,0) 89 | call load_uvw(2,1) 90 | #ifdef saveTSG 91 | call load_tsg(1,0) 92 | call load_tsg(2,1) 93 | #endif 94 | 95 | endif 96 | 97 | do while (tt<=tend) 98 | print*, "tt,tend =====",tt,tend,xyz(1,1,1) 99 | SNPP = min(int(tt/dt_case)+1,NPP) 100 | 101 | if ( mod(tt,dt_case)==0 .and. int(tt/dt_case,8)+1<=NPP) then 102 | call init_particles(SNPP) 103 | endif 104 | 105 | do i=1,int(dt_file/dt) 106 | dtp = real(mod(tt,dt_file))/real(dt_file) 107 | call rk4(SNPP) 108 | tt=tt+dt 109 | count_step=count_step+1 110 | #ifdef isGlider 111 | call save_glider_data(SNPP) 112 | #else 113 | call check_and_save(SNPP) 114 | #endif 115 | enddo 116 | 117 | !reach the end of the records, start to loop velocity from the first record 118 | if (mod(rec_num,Nrecs)==0) then 119 | call load_uvw(1,0) 120 | call load_uvw(2,1) 121 | 122 | #ifdef saveTSG 123 | call load_tsg(1,0) 124 | call load_tsg(2,1) 125 | #endif 126 | 127 | rec_num=rec_num+2 128 | marker(1:2)=(/2,1/) 129 | 130 | #ifndef isArgo 131 | #ifndef isGlider 132 | #ifdef jump_looping 133 | do IPP=1,SNPP 134 | call jump(IPP) 135 | enddo 136 | #endif 137 | #endif 138 | #endif 139 | 140 | iswitch=1 141 | else 142 | rec_num=rec_num+1 143 | 144 | iswitch=abs(iswitch-1) 145 | call load_uvw(rec_num,iswitch) 146 | #ifdef saveTSG 147 | call load_tsg(rec_num,iswitch) 148 | #endif 149 | marker(1:2)=(/rec_num,iswitch/) 150 | endif 151 | 152 | 153 | enddo 154 | 155 | #ifdef isGlider 156 | do i=1,Npts 157 | do IPP=1,NPP 158 | close(save_glider_FnIDs(i,IPP)) 159 | enddo 160 | enddo 161 | #endif 162 | #ifdef isArgo 163 | do i=1,Npts 164 | do IPP=1,NPP 165 | close(save_argo_FnIDs(i,IPP)) 166 | #ifdef saveArgoProfile 167 | close(save_argo_profileIDs(i,IPP)) 168 | #endif 169 | enddo 170 | enddo 171 | #endif 172 | 173 | CALL DATE_AND_TIME(date,time1,zone,time) 174 | print*, "Program started at", time0, "and ended ", time1 175 | !call close_files() 176 | 177 | end program main 178 | 179 | -------------------------------------------------------------------------------- /docs/source/conf.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # -*- coding: utf-8 -*- 3 | # 4 | # Octopus documentation build configuration file, created by 5 | # sphinx-quickstart on Sun Mar 25 22:02:55 2018. 6 | # 7 | # This file is execfile()d with the current directory set to its 8 | # containing dir. 9 | # 10 | # Note that not all possible configuration values are present in this 11 | # autogenerated file. 12 | # 13 | # All configuration values have a default; values that are commented out 14 | # serve to show the default. 15 | 16 | # If extensions (or modules to document with autodoc) are in another directory, 17 | # add these directories to sys.path here. If the directory is relative to the 18 | # documentation root, use os.path.abspath to make it absolute, like shown here. 19 | # 20 | # import os 21 | # import sys 22 | # sys.path.insert(0, os.path.abspath('.')) 23 | 24 | 25 | # -- General configuration ------------------------------------------------ 26 | 27 | # If your documentation needs a minimal Sphinx version, state it here. 28 | # 29 | # needs_sphinx = '1.0' 30 | 31 | # Add any Sphinx extension module names here, as strings. They can be 32 | # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom 33 | # ones. 34 | extensions = ['sphinx.ext.autodoc', 35 | 'sphinx.ext.doctest', 36 | 'sphinx.ext.todo', 37 | 'sphinx.ext.coverage', 38 | 'sphinx.ext.mathjax', 39 | 'sphinx.ext.viewcode', 40 | 'sphinx.ext.githubpages'] 41 | 42 | # Add any paths that contain templates here, relative to this directory. 43 | #templates_path = ['_templates'] 44 | 45 | # The suffix(es) of source filenames. 46 | # You can specify multiple suffix as a list of string: 47 | # 48 | # source_suffix = ['.rst', '.md'] 49 | source_suffix = '.rst' 50 | 51 | # The master toctree document. 52 | master_doc = 'index' 53 | 54 | # General information about the project. 55 | project = 'Octopus' 56 | copyright = '2018, Jinbo Wang' 57 | author = 'Jinbo Wang' 58 | 59 | # The version info for the project you're documenting, acts as replacement for 60 | # |version| and |release|, also used in various other places throughout the 61 | # built documents. 62 | # 63 | # The short X.Y version. 64 | version = '0.1' 65 | # The full version, including alpha/beta/rc tags. 66 | release = '1.0' 67 | 68 | # The language for content autogenerated by Sphinx. Refer to documentation 69 | # for a list of supported languages. 70 | # 71 | # This is also used if you do content translation via gettext catalogs. 72 | # Usually you set "language" from the command line for these cases. 73 | language = None 74 | 75 | # List of patterns, relative to source directory, that match files and 76 | # directories to ignore when looking for source files. 77 | # This patterns also effect to html_static_path and html_extra_path 78 | exclude_patterns = [] 79 | 80 | # The name of the Pygments (syntax highlighting) style to use. 81 | pygments_style = 'sphinx' 82 | 83 | # If true, `todo` and `todoList` produce output, else they produce nothing. 84 | todo_include_todos = True 85 | 86 | 87 | # -- Options for HTML output ---------------------------------------------- 88 | 89 | # The theme to use for HTML and HTML Help pages. See the documentation for 90 | # a list of builtin themes. 91 | # 92 | #html_theme = 'alabaster' 93 | 94 | # Theme options are theme-specific and customize the look and feel of a theme 95 | # further. For a list of options available for each theme, see the 96 | # documentation. 97 | # 98 | # html_theme_options = {} 99 | 100 | # Add any paths that contain custom static files (such as style sheets) here, 101 | # relative to this directory. They are copied after the builtin static files, 102 | # so a file named "default.css" will overwrite the builtin "default.css". 103 | html_static_path = ['_static'] 104 | 105 | 106 | # -- Options for HTMLHelp output ------------------------------------------ 107 | 108 | # Output file base name for HTML help builder. 109 | htmlhelp_basename = 'Octopusdoc' 110 | 111 | 112 | # -- Options for LaTeX output --------------------------------------------- 113 | 114 | latex_elements = { 115 | # The paper size ('letterpaper' or 'a4paper'). 116 | # 117 | # 'papersize': 'letterpaper', 118 | 119 | # The font size ('10pt', '11pt' or '12pt'). 120 | # 121 | # 'pointsize': '10pt', 122 | 123 | # Additional stuff for the LaTeX preamble. 124 | # 125 | # 'preamble': '', 126 | 127 | # Latex figure (float) alignment 128 | # 129 | # 'figure_align': 'htbp', 130 | } 131 | 132 | # Grouping the document tree into LaTeX files. List of tuples 133 | # (source start file, target name, title, 134 | # author, documentclass [howto, manual, or own class]). 135 | latex_documents = [ 136 | (master_doc, 'Octopus.tex', 'Octopus Documentation', 137 | 'Jinbo Wang', 'manual'), 138 | ] 139 | 140 | 141 | # -- Options for manual page output --------------------------------------- 142 | 143 | # One entry per manual page. List of tuples 144 | # (source start file, name, description, authors, manual section). 145 | man_pages = [ 146 | (master_doc, 'octopus', 'Octopus Documentation', 147 | [author], 1) 148 | ] 149 | 150 | 151 | # -- Options for Texinfo output ------------------------------------------- 152 | 153 | # Grouping the document tree into Texinfo files. List of tuples 154 | # (source start file, target name, title, author, 155 | # dir menu entry, description, category) 156 | texinfo_documents = [ 157 | (master_doc, 'Octopus', 'Octopus Documentation', 158 | author, 'Octopus', 'One line description of project.', 159 | 'Miscellaneous'), 160 | ] 161 | 162 | 163 | 164 | -------------------------------------------------------------------------------- /test/src.mitgcm/io.f90: -------------------------------------------------------------------------------- 1 | subroutine load_z_lookup_table() 2 | 3 | use global, only: z2k,k2z,path2uvw 4 | implicit none 5 | real*4::tmp(5701),tmp1(0:420) 6 | open(63,file=trim(path2uvw)//'z_to_k_lookup_table.bin',& 7 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 8 | status='old',recl=4*5701) 9 | read(63,rec=1) tmp 10 | z2k=real(tmp,8) 11 | close(63) 12 | 13 | open(64,file=trim(path2uvw)//'k_to_z_lookup_table.bin',& 14 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 15 | status='old',recl=4*421) 16 | read(64,rec=1) tmp1 17 | k2z=real(tmp1,8) 18 | close(64) 19 | 20 | end subroutine load_z_lookup_table 21 | 22 | subroutine load_mld(tt) 23 | 24 | use global, only: Nx,Ny,dt_mld,tend_file,fn_id_mld,mld 25 | real*8, intent(in) :: tt 26 | integer*8 :: i 27 | 28 | i=int(mod(tt,tend_file)/dt_mld)+1 29 | print*, "load mixed layer depth data at time ",tt, "and step", i 30 | read(fn_id_mld,rec=i) mld(0:Nx-1,0:Ny-1) 31 | 32 | mld(-2:-1,:) = mld(Nx-2:Nx-1,:) 33 | mld(Nx:Nx+1,:)=mld(0:1,:) 34 | 35 | end subroutine load_mld 36 | 37 | 38 | subroutine load_PHIHYD(tt) 39 | 40 | use global, only: Nx,Ny,dt_mld,tend_file,fn_uvwtsg_ids,phihyd 41 | real*8, intent(in) :: tt 42 | integer*8 :: i 43 | 44 | i=int(mod(tt,tend_file)/dt_mld)+1 45 | print*, "load PHIHYD data at time ",tt, "and step", i 46 | read(fn_uvwtsg_ids(7),rec=i) phihyd(0:Nx-1,0:Ny-1) 47 | 48 | phihyd(-2:-1,:) = phihyd(Nx-2:Nx-1,:) 49 | phihyd(Nx:Nx+1,:)=phihyd(0:1,:) 50 | 51 | end subroutine load_PHIHYD 52 | 53 | 54 | subroutine load_uvwtsg(irec,isw) 55 | use global, only : fn_uvwtsg_ids,Nx,Ny,Nz,uu,vv,ww,theta,gam,salt,Nrecs,fn_THETA,fn_SALT,fn_GAMMA 56 | implicit none 57 | INTEGER*8, intent(in) :: irec,isw 58 | !real*4, dimension(-1:Nx+1,0:Ny-1,-1:Nz) :: tmp 59 | integer*8 :: i 60 | i=mod(irec,Nrecs) 61 | if (i .eq. 0) then 62 | i=Nrecs 63 | endif 64 | !$OMP PARALLEL SECTIONS 65 | !$OMP SECTION 66 | call load_3d(fn_uvwtsg_ids(1),irec,uu(:,:,:,isw)) 67 | uu(:,:,-1,isw)=uu(:,:,0,isw) 68 | uu(:,:,Nz,isw)=uu(:,:,Nz-1,isw) 69 | print*, "====>> load UVEL", irec, "min() =", minval(uu(:,:,:,isw)) 70 | !$OMP SECTION 71 | call load_3d(fn_uvwtsg_ids(2),irec,vv(:,:,:,isw)) 72 | 73 | vv(:,:,-1,isw)=vv(:,:,0,isw) 74 | vv(:,:,Nz,isw)=vv(:,:,Nz-1,isw) 75 | print*, "====>> load VVEL", irec, "min() =", minval(vv(:,:,:,isw)) 76 | !$OMP SECTION 77 | call load_3d(fn_uvwtsg_ids(3),irec,ww(:,:,:,isw)) 78 | 79 | ww(:,:,-1,isw)=0d0 !reflective surface ghost cell 80 | ww(:,:,Nz,isw)=0d0 !reflective bottom ghost cell 81 | 82 | print*, "====>> load WVEL", irec, "min() =", minval(ww(:,:,:,isw)) 83 | 84 | !$OMP SECTION 85 | if (trim(fn_THETA) .ne. '') then 86 | call load_3d(fn_uvwtsg_ids(4),irec,theta(:,:,:,isw)) 87 | theta(:,:,-1,isw)=theta(:,:,0,isw) 88 | theta(:,:,Nz,isw)=theta(:,:,Nz-1,isw) 89 | print*, "====>> load THETA", irec, "min() =", minval(theta(:,:,:,isw)),maxval(theta(:,:,:,isw)) 90 | endif 91 | 92 | !$OMP SECTION 93 | if (trim(fn_THETA) .ne. '') then 94 | call load_3d(fn_uvwtsg_ids(5),irec,salt(:,:,:,isw)) 95 | 96 | salt(:,:,-1,isw)=salt(:,:,0,isw) 97 | salt(:,:,Nz,isw)=salt(:,:,Nz-1,isw) 98 | 99 | print*, "====>> load SALT", irec, "min() =", minval(salt(:,:,:,isw)) 100 | endif 101 | !$OMP SECTION 102 | if (trim(fn_THETA) .ne. '') then 103 | call load_3d(fn_uvwtsg_ids(6),irec,gam(:,:,:,isw)) 104 | 105 | gam(:,:,-1,isw)=gam(:,:,0,isw) 106 | gam(:,:,Nz,isw)=gam(:,:,Nz-1,isw) 107 | 108 | where(gam(:,:,:,isw)<20) gam(:,:,:,isw)=0d0 109 | print*, "====>> load GAMMA", irec, "min() =", minval(gam(:,:,:,isw)) 110 | endif 111 | !$OMP END PARALLEL SECTIONS 112 | 113 | print*, "end loading data" 114 | end subroutine load_uvwtsg 115 | 116 | 117 | subroutine load_grid() 118 | 119 | use global, only : dxg_r,dyg_r,drf_r,Nx,Ny,Nz,hFacC,path2uvw!,hFacS,hFacW 120 | 121 | implicit none 122 | real*4 :: tmp(0:Nx-1,0:Ny-1),tmp1(0:Nz-1) 123 | 124 | print*, '11' 125 | print*, "=================================================" 126 | print*, "loading grid ......... " 127 | 128 | open(91,file=trim(path2uvw)//'dxg.bin',& 129 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 130 | status='old',recl=4*Nx*Ny) 131 | read(91,rec=1) tmp 132 | dxg_r(0:Nx-1,0:Ny-1)=real(tmp,8) 133 | dxg_r(Nx:Nx+1,:)=dxg_r(0:1,:) 134 | dxg_r(-2:-1,:)=dxg_r(Nx-2:Nx-1,:) 135 | dxg_r = 1.0/dxg_r 136 | close(91) 137 | 138 | open(92,file=trim(path2uvw)//'dyg.bin',& 139 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 140 | status='old',recl=4*Nx*Ny) 141 | read(92,rec=1) tmp 142 | dyg_r(0:Nx-1,0:Ny-1)=real(tmp,8) 143 | dyg_r(Nx:Nx+1,:)=dyg_r(0:1,:) 144 | dyg_r(-2:-1,:)=dyg_r(Nx-2:Nx-1,:) 145 | dyg_r = 1.0/dyg_r 146 | close(92) 147 | 148 | open(93,file=trim(path2uvw)//'drf.bin',& 149 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 150 | status='old',recl=4*Nz) 151 | read(93,rec=1) tmp1 152 | drf_r(0:Nz-1)=real(tmp1,8) 153 | drf_r(-1)=drf_r(0) 154 | drf_r(Nz)=drf_r(Nz-1) 155 | drf_r = 1.0/drf_r 156 | close(93) 157 | print*, '11' 158 | open(94,file=trim(path2uvw)//'hFacC.bin',& 159 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 160 | status='old',recl=4*Nz*Ny*Nx) 161 | read(94,rec=1) hFacC(0:Nx-1,0:Ny-1,0:Nz-1) 162 | hFacC(Nx:Nx+1,:,:)=hFacC(0:1,:,:) 163 | hFacC(-2:-1,:,:)=hFacC(Nx-2:Nx-1,:,:) 164 | hFacC(:,:,-1)=hFacC(:,:,0) 165 | hFacC(:,:,Nz)=0d0 166 | close(94) 167 | ! 168 | ! open(4,file='hFacS.bin',& 169 | ! form='unformatted',access='direct',convert='BIG_ENDIAN',& 170 | ! status='old',recl=4*Nz*Ny*Nx) 171 | ! read(4,rec=1) hFacS(0:Nx-1,:,0:Nz-1) 172 | ! hFacS(Nx:Nx+1,:,:)=hFacS(0:1,:,:) 173 | ! hFacS(-1,:,:)=hFacS(Nx-1,:,:) 174 | ! hFacS(:,:,-1)=hFacS(:,:,0) 175 | ! close(4) 176 | 177 | ! open(4,file='hFacW.bin',& 178 | ! form='unformatted',access='direct',convert='BIG_ENDIAN',& 179 | ! status='old',recl=4*Nz*Ny*Nx) 180 | ! read(4,rec=1) hFacW(0:Nx-1,:,0:Nz-1) 181 | ! hFacW(Nx:Nx+1,:,:)=hFacW(0:1,:,:) 182 | ! hFacW(-1,:,:)=hFacW(Nx-1,:,:) 183 | ! hFacW(:,:,-1)=hFacW(:,:,0) 184 | ! close(4) 185 | 186 | end subroutine load_grid 187 | 188 | 189 | 190 | -------------------------------------------------------------------------------- /test/src.mitgcm/random.f90: -------------------------------------------------------------------------------- 1 | MODULE random 2 | ! A module for random number generation from the following distributions: 3 | ! 4 | ! Distribution Function/subroutine name 5 | ! 6 | ! Normal (Gaussian) random_normal 7 | ! Gamma random_gamma 8 | ! Chi-squared random_chisq 9 | ! Exponential random_exponential 10 | ! Weibull random_Weibull 11 | ! Beta random_beta 12 | ! t random_t 13 | ! Multivariate normal random_mvnorm 14 | ! Generalized inverse Gaussian random_inv_gauss 15 | ! Poisson random_Poisson 16 | ! Binomial random_binomial1 * 17 | ! random_binomial2 * 18 | ! Negative binomial random_neg_binomial 19 | ! von Mises random_von_Mises 20 | ! Cauchy random_Cauchy 21 | ! 22 | ! Generate a random ordering of the integers 1 .. N 23 | ! random_order 24 | ! Initialize (seed) the uniform random number generator for ANY compiler 25 | ! seed_random_number 26 | 27 | ! Lognormal - see note below. 28 | 29 | ! ** Two functions are provided for the binomial distribution. 30 | ! If the parameter values remain constant, it is recommended that the 31 | ! first function is used (random_binomial1). If one or both of the 32 | ! parameters change, use the second function (random_binomial2). 33 | 34 | ! The compilers own random number generator, SUBROUTINE RANDOM_NUMBER(r), 35 | ! is used to provide a source of uniformly distributed random numbers. 36 | 37 | ! N.B. At this stage, only one random number is generated at each call to 38 | ! one of the functions above. 39 | 40 | ! The module uses the following functions which are included here: 41 | ! bin_prob to calculate a single binomial probability 42 | ! lngamma to calculate the logarithm to base e of the gamma function 43 | 44 | ! Some of the code is adapted from Dagpunar's book: 45 | ! Dagpunar, J. 'Principles of random variate generation' 46 | ! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 47 | ! 48 | ! In most of Dagpunar's routines, there is a test to see whether the value 49 | ! of one or two floating-point parameters has changed since the last call. 50 | ! These tests have been replaced by using a logical variable FIRST. 51 | ! This should be set to .TRUE. on the first call using new values of the 52 | ! parameters, and .FALSE. if the parameter values are the same as for the 53 | ! previous call. 54 | 55 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 56 | ! Lognormal distribution 57 | ! If X has a lognormal distribution, then log(X) is normally distributed. 58 | ! Here the logarithm is the natural logarithm, that is to base e, sometimes 59 | ! denoted as ln. To generate random variates from this distribution, generate 60 | ! a random deviate from the normal distribution with mean and variance equal 61 | ! to the mean and variance of the logarithms of X, then take its exponential. 62 | 63 | ! Relationship between the mean & variance of log(X) and the mean & variance 64 | ! of X, when X has a lognormal distribution. 65 | ! Let m = mean of log(X), and s^2 = variance of log(X) 66 | ! Then 67 | ! mean of X = exp(m + 0.5s^2) 68 | ! variance of X = (mean(X))^2.[exp(s^2) - 1] 69 | 70 | ! In the reverse direction (rarely used) 71 | ! variance of log(X) = log[1 + var(X)/(mean(X))^2] 72 | ! mean of log(X) = log(mean(X) - 0.5var(log(X)) 73 | 74 | ! N.B. The above formulae relate to population parameters; they will only be 75 | ! approximate if applied to sample values. 76 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 77 | 78 | ! Version 1.13, 2 October 2000 79 | ! Changes from version 1.01 80 | ! 1. The random_order, random_Poisson & random_binomial routines have been 81 | ! replaced with more efficient routines. 82 | ! 2. A routine, seed_random_number, has been added to seed the uniform random 83 | ! number generator. This requires input of the required number of seeds 84 | ! for the particular compiler from a specified I/O unit such as a keyboard. 85 | ! 3. Made compatible with Lahey's ELF90. 86 | ! 4. Marsaglia & Tsang algorithm used for random_gamma when shape parameter > 1. 87 | ! 5. INTENT for array f corrected in random_mvnorm. 88 | 89 | ! Author: Alan Miller 90 | ! e-mail: amiller @ bigpond.net.au 91 | 92 | IMPLICIT NONE 93 | REAL, PRIVATE :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0, & 94 | vsmall = TINY(1.0), vlarge = HUGE(1.0) 95 | !PRIVATE :: integral 96 | INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) 97 | 98 | 99 | CONTAINS 100 | 101 | 102 | FUNCTION random_normal() RESULT(fn_val) 103 | 104 | ! Adapted from the following Fortran 77 code 105 | ! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. 106 | ! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, 107 | ! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. 108 | 109 | ! The function random_normal() returns a normally distributed pseudo-random 110 | ! number with zero mean and unit variance. 111 | 112 | ! The algorithm uses the ratio of uniforms method of A.J. Kinderman 113 | ! and J.F. Monahan augmented with quadratic bounding curves. 114 | 115 | REAL :: fn_val 116 | 117 | ! Local variables 118 | REAL :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472, & 119 | r1 = 0.27597, r2 = 0.27846, u, v, x, y, q 120 | 121 | ! Generate P = (u,v) uniform in rectangle enclosing acceptance region 122 | 123 | DO 124 | CALL RANDOM_NUMBER(u) 125 | CALL RANDOM_NUMBER(v) 126 | v = 1.7156 * (v - half) 127 | 128 | ! Evaluate the quadratic form 129 | x = u - s 130 | y = ABS(v) - t 131 | q = x**2 + y*(a*y - b*x) 132 | 133 | ! Accept P if inside inner ellipse 134 | IF (q < r1) EXIT 135 | ! Reject P if outside outer ellipse 136 | IF (q > r2) CYCLE 137 | ! Reject P if outside acceptance region 138 | IF (v**2 < -4.0*LOG(u)*u**2) EXIT 139 | END DO 140 | 141 | ! Return ratio of P's coordinates as the normal deviate 142 | fn_val = v/u 143 | RETURN 144 | 145 | END FUNCTION random_normal 146 | 147 | 148 | END MODULE random 149 | -------------------------------------------------------------------------------- /src/random.f90: -------------------------------------------------------------------------------- 1 | MODULE random 2 | ! A module for random number generation from the following distributions: 3 | ! 4 | ! Distribution Function/subroutine name 5 | ! 6 | ! Normal (Gaussian) random_normal 7 | ! Gamma random_gamma 8 | ! Chi-squared random_chisq 9 | ! Exponential random_exponential 10 | ! Weibull random_Weibull 11 | ! Beta random_beta 12 | ! t random_t 13 | ! Multivariate normal random_mvnorm 14 | ! Generalized inverse Gaussian random_inv_gauss 15 | ! Poisson random_Poisson 16 | ! Binomial random_binomial1 * 17 | ! random_binomial2 * 18 | ! Negative binomial random_neg_binomial 19 | ! von Mises random_von_Mises 20 | ! Cauchy random_Cauchy 21 | ! 22 | ! Generate a random ordering of the integers 1 .. N 23 | ! random_order 24 | ! Initialize (seed) the uniform random number generator for ANY compiler 25 | ! seed_random_number 26 | 27 | ! Lognormal - see note below. 28 | 29 | ! ** Two functions are provided for the binomial distribution. 30 | ! If the parameter values remain constant, it is recommended that the 31 | ! first function is used (random_binomial1). If one or both of the 32 | ! parameters change, use the second function (random_binomial2). 33 | 34 | ! The compilers own random number generator, SUBROUTINE RANDOM_NUMBER(r), 35 | ! is used to provide a source of uniformly distributed random numbers. 36 | 37 | ! N.B. At this stage, only one random number is generated at each call to 38 | ! one of the functions above. 39 | 40 | ! The module uses the following functions which are included here: 41 | ! bin_prob to calculate a single binomial probability 42 | ! lngamma to calculate the logarithm to base e of the gamma function 43 | 44 | ! Some of the code is adapted from Dagpunar's book: 45 | ! Dagpunar, J. 'Principles of random variate generation' 46 | ! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 47 | ! 48 | ! In most of Dagpunar's routines, there is a test to see whether the value 49 | ! of one or two floating-point parameters has changed since the last call. 50 | ! These tests have been replaced by using a logical variable FIRST. 51 | ! This should be set to .TRUE. on the first call using new values of the 52 | ! parameters, and .FALSE. if the parameter values are the same as for the 53 | ! previous call. 54 | 55 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 56 | ! Lognormal distribution 57 | ! If X has a lognormal distribution, then log(X) is normally distributed. 58 | ! Here the logarithm is the natural logarithm, that is to base e, sometimes 59 | ! denoted as ln. To generate random variates from this distribution, generate 60 | ! a random deviate from the normal distribution with mean and variance equal 61 | ! to the mean and variance of the logarithms of X, then take its exponential. 62 | 63 | ! Relationship between the mean & variance of log(X) and the mean & variance 64 | ! of X, when X has a lognormal distribution. 65 | ! Let m = mean of log(X), and s^2 = variance of log(X) 66 | ! Then 67 | ! mean of X = exp(m + 0.5s^2) 68 | ! variance of X = (mean(X))^2.[exp(s^2) - 1] 69 | 70 | ! In the reverse direction (rarely used) 71 | ! variance of log(X) = log[1 + var(X)/(mean(X))^2] 72 | ! mean of log(X) = log(mean(X) - 0.5var(log(X)) 73 | 74 | ! N.B. The above formulae relate to population parameters; they will only be 75 | ! approximate if applied to sample values. 76 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 77 | 78 | ! Version 1.13, 2 October 2000 79 | ! Changes from version 1.01 80 | ! 1. The random_order, random_Poisson & random_binomial routines have been 81 | ! replaced with more efficient routines. 82 | ! 2. A routine, seed_random_number, has been added to seed the uniform random 83 | ! number generator. This requires input of the required number of seeds 84 | ! for the particular compiler from a specified I/O unit such as a keyboard. 85 | ! 3. Made compatible with Lahey's ELF90. 86 | ! 4. Marsaglia & Tsang algorithm used for random_gamma when shape parameter > 1. 87 | ! 5. INTENT for array f corrected in random_mvnorm. 88 | 89 | ! Author: Alan Miller 90 | ! e-mail: amiller @ bigpond.net.au 91 | 92 | IMPLICIT NONE 93 | REAL, PRIVATE :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0, & 94 | vsmall = TINY(1.0), vlarge = HUGE(1.0) 95 | !PRIVATE :: integral 96 | INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) 97 | 98 | 99 | CONTAINS 100 | 101 | 102 | FUNCTION random_normal() RESULT(fn_val) 103 | 104 | ! Adapted from the following Fortran 77 code 105 | ! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. 106 | ! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, 107 | ! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. 108 | 109 | ! The function random_normal() returns a normally distributed pseudo-random 110 | ! number with zero mean and unit variance. 111 | 112 | ! The algorithm uses the ratio of uniforms method of A.J. Kinderman 113 | ! and J.F. Monahan augmented with quadratic bounding curves. 114 | 115 | REAL :: fn_val 116 | 117 | ! Local variables 118 | REAL :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472, & 119 | r1 = 0.27597, r2 = 0.27846, u, v, x, y, q 120 | 121 | ! Generate P = (u,v) uniform in rectangle enclosing acceptance region 122 | 123 | DO 124 | CALL RANDOM_NUMBER(u) 125 | CALL RANDOM_NUMBER(v) 126 | v = 1.7156 * (v - half) 127 | 128 | ! Evaluate the quadratic form 129 | x = u - s 130 | y = ABS(v) - t 131 | q = x**2 + y*(a*y - b*x) 132 | 133 | ! Accept P if inside inner ellipse 134 | IF (q < r1) EXIT 135 | ! Reject P if outside outer ellipse 136 | IF (q > r2) CYCLE 137 | ! Reject P if outside acceptance region 138 | IF (v**2 < -4.0*LOG(u)*u**2) EXIT 139 | END DO 140 | 141 | ! Return ratio of P's coordinates as the normal deviate 142 | fn_val = v/u 143 | RETURN 144 | 145 | END FUNCTION random_normal 146 | 147 | 148 | END MODULE random 149 | -------------------------------------------------------------------------------- /src/particles.f90: -------------------------------------------------------------------------------- 1 | #include "cppdefs.h" 2 | #ifdef allow_particle 3 | 4 | MODULE particles 5 | USE header, ONLY : 6 | NI,NJ,NK,uf,vf,wf,Jifc,Jjfc,J2d,ux,vy,NPR,wz,PI,dtf,vor,shear,rho,strain,zf,& 7 | &s,parti_file_num,DL,rc_kind, pcx, pcy, pcz, pcr, 8 | dirout 9 | 10 | ! define the class for particles 11 | TYPE particle 12 | REAL(kind=rc_kind) :: 13 | i,j,k,x,y,z,u,v,w,s,t,u0,v0,w0,id,vor,strain,shear,rho,time 14 | END TYPE particle 15 | 16 | TYPE (particle), DIMENSION(:), ALLOCATABLE :: parti 17 | REAL(kind=rc_kind) :: dz,swap1,swap2,swap3 18 | INTEGER,ALLOCATABLE :: file_id(:) 19 | INTEGER :: NPR_eachfile 20 | CHARACTER(len=3) :: file_id_char 21 | 22 | PRIVATE :: NPR_eachfile, file_id_char, dz, swap1, swap2, swap3, 23 | file_id 24 | PUBLIC :: parti 25 | 26 | CONTAINS 27 | 28 | SUBROUTINE open_parti_files() 29 | IMPLICIT NONE 30 | INTEGER :: fi 31 | 32 | ALLOCATE (file_id(parti_file_num)) 33 | IF (MOD(NPR,parti_file_num) .NE. 0) THEN 34 | PRINT*, "Error: Please make sure NPR/file_num = integer in 35 | mod_particles.f90" 36 | PRINT*, "Stop model" 37 | STOP 38 | ENDIF 39 | 40 | NPR_eachfile = NPR/parti_file_num !the particle number in each file 41 | ! PRINT*, "# each file contains ",NPR_eachfile,"particles" 42 | 43 | !open files 44 | DO fi = 1, parti_file_num 45 | WRITE(file_id_char,'(I3.3)') fi 46 | file_id(fi) = 2000 + fi 47 | OPEN(file_id(fi), file = 48 | TRIM(dirout)//'op.parti-'//file_id_char//'.bin', & 49 | &form = 'unformatted', access = 'stream', status = 'replace') 50 | ! PRINT*, "open file 51 | ! "//TRIM(dirout)//'op.parti-'//file_id_char//'.bin' 52 | ENDDO 53 | 54 | END SUBROUTINE open_parti_files 55 | 56 | SUBROUTINE save_parti() 57 | IMPLICIT NONE 58 | INTEGER :: i_file,i 59 | 60 | PRINT*,"SAVE PARTICLES" 61 | SELECT CASE(0) 62 | CASE (0) 63 | !save limited variables 64 | DO i_file = 1, parti_file_num 65 | DO i = (i_file - 1) * NPR_eachfile + 1, i_file * NPR_eachfile 66 | WRITE(file_id(i_file)) parti(i)%i, & 67 | parti(i)%j, & 68 | parti(i)%k, & 69 | parti(i)%z, & 70 | !parti(i)%u, & 71 | !parti(i)%v, & 72 | parti(i)%w, & 73 | parti(i)%rho, & 74 | !parti(i)%s, & 75 | !parti(i)%t, & 76 | parti(i)%vor, & 77 | parti(i)%shear, & 78 | parti(i)%strain 79 | ENDDO 80 | ENDDO 81 | 82 | END SELECT 83 | 84 | END SUBROUTINE save_parti 85 | 86 | 87 | SUBROUTINE ini_particles(time) 88 | IMPLICIT NONE 89 | INTEGER :: i,j,k,time,itmp,npr_eachline 90 | REAL(kind=rc_kind) :: rand,r,theta, x1, y1 91 | INTEGER,PARAMETER :: seed = 86456 92 | 93 | ! PRINT*, "initialize files to save particles" 94 | CALL open_parti_files() 95 | 96 | CALL RANDOM_SEED() 97 | 98 | ! PRINT*, "# ini particles' velocities",NPR 99 | DO i=1, NPR 100 | parti(i)%time = DBLE(time) 101 | parti(i)%u0=0d0 102 | parti(i)%v0=0d0 103 | parti(i)%w0=0d0 104 | parti(i)%u=0d0 105 | parti(i)%v=0d0 106 | parti(i)%w=0d0 107 | parti(i)%t=0d0 108 | parti(i)%s=0d0 109 | parti(i)%rho=0d0 110 | parti(i)%vor=0d0 111 | parti(i)%shear=0d0 112 | parti(i)%strain=0d0 113 | ENDDO 114 | ! PRINT*, "# finish intial particles' velocities" 115 | 116 | DO i=1, NPR 117 | parti(i)%i=REAL(i*REAL(NI)/REAL(NPR)) 118 | parti(i)%j=90. 119 | parti(i)%k=2. 120 | ENDDO 121 | 122 | END SUBROUTINE ini_particles 123 | 124 | 125 | SUBROUTINE get_parti_vel(time) 126 | IMPLICIT NONE 127 | INTEGER :: i,j,k,ip,ic,jc,kc,ifc,jfc,kfc,time 128 | REAL(kind=rc_kind) :: dic,djc,dkc,dif,djf,dkf 129 | REAL(kind=rc_kind), DIMENSION( 0:NI,0:NJ+1 ) :: uxf 130 | REAL(kind=rc_kind), DIMENSION( 0:NI+1,0:NJ ) :: vyf 131 | REAL(kind=rc_kind), DIMENSION( 0:NI+1,0:NJ+1,0:NK ) :: wzf 132 | REAL(kind=rc_kind), DIMENSION( NI, 0:NJ, NK) :: vfp 133 | REAL(kind=rc_kind), DIMENSION( 0:NI+1,0:NJ, 0:NK+1) :: 134 | vf_ex 135 | REAL(kind=rc_kind), DIMENSION( 0:NI, NJ, NK) :: ufp 136 | REAL(kind=rc_kind), DIMENSION( 0:NI, 0:NJ+1, 0:NK+1) :: 137 | uf_ex 138 | REAL(kind=rc_kind), DIMENSION( NI, NJ, 0:NK) :: wfp 139 | REAL(kind=rc_kind), DIMENSION( 0:NI+1,0:NJ+1, 0:NK) :: 140 | wf_ex 141 | 142 | !rearrange the ux and vy to face grids 143 | !uxf = 0.5d0*(ux(0:NI,:)+ux(1:NI+1,:)) 144 | !vyf = 0.5d0*(vy(:,0:NJ)+vy(:,1:NJ+1)) 145 | wzf = 0.5d0*(wz(:,:,0:NK) + wz(:,:,1:NK+1)) 146 | 147 | !calculate the face velocity 148 | k=0 149 | wfp(:,:,k) = wf(:,:,k)/J2d(1:NI,1:NJ)*wzf(1:NI,1:NJ,k) 150 | 151 | DO k = 1, NK 152 | ufp(:,:,k) = uf(:,:,k)/Jifc(:,:,k) 153 | vfp(:,:,k) = vf(:,:,k)/Jjfc(:,:,k) 154 | wfp(:,:,k) = wf(:,:,k)/J2d(1:NI,1:NJ)*wzf(1:NI,1:NJ,k) 155 | ENDDO 156 | uf_ex=0d0 157 | uf_ex(:,1:NJ,1:NK) = ufp 158 | !=== vertical extrapolation 159 | uf_ex(:,:,NK+1) = 2*uf_ex(:,:,NK)-uf_ex(:,:,NK-1) ! extrapolation 160 | 161 | vf_ex=0d0 162 | vf_ex(1:NI,:,1:NK) = vfp 163 | !=== zonally periodic 164 | vf_ex(0,:,:) = vf_ex(NI,:,:) 165 | vf_ex(NI+1,:,:)=vf_ex(1,:,:) 166 | !=== vertical extrapolation 167 | vf_ex(:,:,NK+1) = 2*vf_ex(:,:,NK)-vf_ex(:,:,NK-1) 168 | 169 | wf_ex=0d0 170 | wf_ex(1:NI,1:NJ,:) = wfp 171 | !===zonal periodic condition 172 | wf_ex(0,:,:) = wf_ex(NI,:,:) 173 | wf_ex(NI+1,:,:) = wf_ex(1,:,:) 174 | !=== 175 | DO ip = 1, NPR 176 | parti(ip)%time=DBLE(time) 177 | IF (parti(ip)%j < NJ .AND. parti(ip)%j > 0 .AND. & 178 | parti(ip)%k < NK .AND. parti(ip)%k > 0) THEN 179 | !ic, jc, kc, is the integer index of the particle relative to 180 | !the grids center. Use these values for variables with the 181 | !ghost points. 182 | !ifc, jfc, and kfc is the index relative to the coordinates of 183 | !grid faces. 184 | !Use these values for variables on faces. 185 | ic = INT(parti(ip)%i+0.5d0) 186 | jc = INT(parti(ip)%j+0.5d0) 187 | kc = INT(parti(ip)%k+0.5d0) 188 | 189 | ifc = INT(parti(ip)%i) 190 | jfc = INT(parti(ip)%j) 191 | kfc = INT(parti(ip)%k) 192 | 193 | dif = parti(ip)%i - ifc 194 | djf = parti(ip)%j - jfc 195 | dkf = parti(ip)%k - kfc 196 | 197 | !call sigma2z(ifc,jfc,parti(ip)%k,parti(ip)%z) 198 | !dzf is the normalized distance of a particle to bottom faces. 199 | !dzf = (parti(ip)%z - zf(ifc,jfc,kfc)) / ( zf(ifc,jfc,kfc+1) - 200 | !zf(ifc,jfc,kfc) ) 201 | 202 | dic = parti(ip)%i - ic + 0.5d0 203 | djc = parti(ip)%j - jc + 0.5d0 204 | dkc = parti(ip)%k - kc + 0.5d0 205 | !calcuate the zonal velocity 206 | CALL 207 | Csigma2z(parti(ip)%i,parti(ip)%j+0.5d0,parti(ip)%k+0.5,swap1) 208 | CALL sigma2z(parti(ip)%i,parti(ip)%j+0.5d0,dble(kc),swap2) 209 | CALL sigma2z(parti(ip)%i,parti(ip)%j+0.5d0,dble(kc+1),swap3) 210 | dz = (swap1 - swap2) / ( swap3 - swap2 ) 211 | 212 | CALL 213 | Cinterp_trilinear(dif,djc,dz,uf_ex(ifc:ifc+1,jc:jc+1,kc:kc+1),parti(ip)%u) 214 | !CALL 215 | !interp_trilinear(dif,djc,dkc,uf_ex(ifc:ifc+1,jc:jc+1,kc:kc+1),parti(ip)%u) 216 | 217 | !calcuate the meridional velocity 218 | CALL 219 | Csigma2z(parti(ip)%i+0.5d0,parti(ip)%j,parti(ip)%k+0.5d0,swap1) 220 | CALL sigma2z(parti(ip)%i+0.5d0,parti(ip)%j,dble(kc),swap2) 221 | CALL sigma2z(parti(ip)%i+0.5d0,parti(ip)%j,dble(kc+1),swap3) 222 | dz = (swap1 - swap2) / ( swap3 - swap2 ) 223 | CALL 224 | Cinterp_trilinear(dic,djf,dz,vf_ex(ic:ic+1,jfc:jfc+1,kc:kc+1),parti(ip)%v) 225 | !CALL 226 | !interp_trilinear(dic,djf,dkc,vf_ex(ic:ic+1,jfc:jfc+1,kc:kc+1),parti(ip)%v) 227 | 228 | !calcuate the vertical velocity 229 | CALL sigma2z(parti(ip)%i,parti(ip)%j,parti(ip)%k,swap1) 230 | CALL sigma2z(parti(ip)%i,parti(ip)%j,dble(kfc),swap2) 231 | CALL sigma2z(parti(ip)%i,parti(ip)%j,dble(kfc+1),swap3) 232 | dz = (swap1 - swap2) / ( swap3 - swap2 ) 233 | parti(ip)%z=swap1*DL 234 | CALL 235 | Cinterp_trilinear(dic,djc,dz,wf_ex(ic:ic+1,jc:jc+1,kfc:kfc+1),parti(ip)%w) 236 | !CALL 237 | !interp_trilinear(dic,djc,dkf,wf_ex(ic:ic+1,jc:jc+1,kfc:kfc+1),parti(ip)%w) 238 | 239 | !diagnose other properties 240 | CALL 241 | Csigma2z(parti(ip)%i+0.5d0,parti(ip)%j+0.5d0,parti(ip)%k+0.5d0,swap1) 242 | CALL 243 | Csigma2z(parti(ip)%i+0.5d0,parti(ip)%j+0.5d0,dble(kc),swap2) 244 | CALL 245 | Csigma2z(parti(ip)%i+0.5d0,parti(ip)%j+0.5d0,dble(kc+1),swap3) 246 | dz = (swap1 - swap2) / ( swap3 - swap2 ) 247 | 248 | CALL 249 | Cinterp_trilinear(dic,djc,dz,vor(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%vor) 250 | CALL 251 | Cinterp_trilinear(dic,djc,dz,rho(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%rho) 252 | CALL 253 | Cinterp_trilinear(dic,djc,dz,shear(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%shear) 254 | CALL 255 | Cinterp_trilinear(dic,djc,dz,strain(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%strain) 256 | !!$ if (ip == 8001) then 257 | !!$ print*, 'dkc,dz=',dkc,dz 258 | !!$ print*, 'dic,djc',dic,djc 259 | !!$ Print*, 'rho=',rho(ic:ic+1,jc:jc+1,kc:kc+1) 260 | !!$ print*, 'parti(ip)rho=',parti(ip)%rho 261 | !!$ endif 262 | !CALL 263 | !interp_trilinear(dic,djc,dkc,vor(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%vor) 264 | !CALL 265 | !interp_trilinear(dic,djc,dkc,s(ic:ic+1,jc:jc+1,kc:kc+1,0),parti(ip)%vor) 266 | !CALL 267 | !interp_trilinear(dic,djc,dkc,shear(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%shear) 268 | !CALL 269 | !interp_trilinear(dic,djc,dkc,strain(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%strain) 270 | !parti(ip)%shear = dz 271 | !parti(ip)%strain = dkc 272 | !parti(ip)%r = rho(ic:ic+1,jc:jc+1,kc:kc+1) 273 | 274 | ELSE 275 | parti(ip)%u=0d0 276 | parti(ip)%v=0d0 277 | parti(ip)%w=0d0 278 | ENDIF 279 | ENDDO 280 | ! get the zonal velocity u 281 | 282 | END SUBROUTINE get_parti_vel 283 | 284 | SUBROUTINE parti_forward() 285 | IMPLICIT NONE 286 | INTEGER :: i 287 | DO i = 1, NPR 288 | parti(i)%i = parti(i)%i + 0.5d0 * dtf * (3d0 * parti(i)%u - 289 | parti(i)%u0) 290 | IF (parti(i)%i >NI) parti(i)%i = parti(i)%i - REAL(NI) 291 | IF (parti(i)%i <0d0 ) parti(i)%i = parti(i)%i + REAL(NI) 292 | 293 | IF (parti(i)%j>NJ-1 .AND. parti(i)%v>0) THEN 294 | parti(i)%j = parti(i)%j + parti(i)%v * dtf / (1d0 + 295 | (parti(i)%v * dtf)/(DBLE(NJ) - parti(i)%j) ) 296 | ELSE IF (parti(i)%j<1 .AND. parti(i)%v<0) THEN 297 | parti(i)%j = parti(i)%j + parti(i)%v * dtf / ( 1d0 - 298 | dtf/parti(i)%j ) 299 | ELSE 300 | parti(i)%j = parti(i)%j + 0.5d0 * dtf * (3d0 * parti(i)%v - 301 | parti(i)%v0) 302 | ENDIF 303 | 304 | IF (parti(i)%k>NK-1 .AND. parti(i)%w>0) THEN 305 | parti(i)%k = parti(i)%k + parti(i)%w * dtf / (1d0 + 306 | (parti(i)%w * dtf)/(DBLE(NK) - parti(i)%k) ) 307 | ELSE IF (parti(i)%k<1 .AND. parti(i)%w<0) THEN 308 | parti(i)%k = parti(i)%k + parti(i)%w * dtf / ( 1d0 - 309 | dtf/parti(i)%k ) 310 | ELSE 311 | parti(i)%k = parti(i)%k + 0.5d0 * dtf * (3d0 * parti(i)%w - 312 | parti(i)%w0) 313 | ENDIF 314 | 315 | !debug part 316 | IF (parti(i)%j<0d0 .OR. parti(i)%j>NJ .OR. parti(i)%k>NK .OR. 317 | parti(i)%k<0d0 ) THEN 318 | PRINT*, "particles coordinates are wrong, 319 | iPR=",i,"j,k",parti(i)%j,parti(i)%k 320 | !stop 321 | ENDIF 322 | 323 | parti(i)%u0 = parti(i)%u 324 | parti(i)%v0 = parti(i)%v 325 | parti(i)%w0 = parti(i)%w 326 | ENDDO 327 | 328 | END SUBROUTINE parti_forward 329 | 330 | 331 | SUBROUTINE interp_trilinear(di,dj,dk,var,velp) 332 | !== give 8 corner points of a cube, interpolate point values inside 333 | !of the cube 334 | !== di is the distance between the particle to the left face 335 | !== dj is the distance between the particle to the southern face 336 | !== dk is the distance between the particle and the bottom face 337 | IMPLICIT NONE 338 | REAL(kind=rc_kind), INTENT(in) :: di,dj,dk 339 | REAL(kind=rc_kind), INTENT(in), DIMENSION( 2, 2 , 2 ) 340 | :: var 341 | REAL(kind=rc_kind), INTENT(out) :: velp 342 | REAL(kind=rc_kind) :: i1,i2,i3,i4,j1,j2,ti,tj,tk 343 | 344 | ! calcuate the Trilinear interpolation 345 | i1 = (var(2,1, 1) - var(1,1, 1))*di + var(1,1, 1) 346 | i2 = (var(2,1, 2) - var(1,1,2))*di + var(1,1, 2) 347 | i3 = (var(2,2,2) - var(1,2,2))*di +var(1,2,2) 348 | i4 = (var(2,2,1) - var(1,2,1))*di + var(1,2,1) 349 | 350 | j1 = (i3 - i2)*dj + i2 351 | j2 = (i4 - i1)*dj + i1 352 | 353 | velp = (j1 - j2) * dk + j2 354 | !print*, 'dz,j1,j2,velp=',dk,j1,j2,velp 355 | END SUBROUTINE interp_trilinear 356 | 357 | SUBROUTINE get_parti_vel_ana() 358 | INTEGER :: ip 359 | DO ip = 1, NPR 360 | parti(ip)%u = 361 | -1*SIN(pi*parti(ip)%i/REAL(NI))*COS(pi*parti(ip)%j/REAL(NJ)) 362 | parti(ip)%v = 363 | COS(pi*parti(ip)%i/REAL(NI))*SIN(pi*parti(ip)%j/REAL(NJ)) 364 | ENDDO 365 | END SUBROUTINE get_parti_vel_ana 366 | 367 | 368 | END MODULE particles 369 | 370 | #endif 371 | -------------------------------------------------------------------------------- /test/src.mitgcm/particles.f90: -------------------------------------------------------------------------------- 1 | #include "cppdefs.h" 2 | #ifdef allow_particle 3 | 4 | MODULE particles 5 | USE header, ONLY : 6 | NI,NJ,NK,uf,vf,wf,Jifc,Jjfc,J2d,ux,vy,NPR,wz,PI,dtf,vor,shear,rho,strain,zf,& 7 | &s,parti_file_num,DL,rc_kind, pcx, pcy, pcz, pcr, 8 | dirout 9 | 10 | ! define the class for particles 11 | TYPE particle 12 | REAL(kind=rc_kind) :: 13 | i,j,k,x,y,z,u,v,w,s,t,u0,v0,w0,id,vor,strain,shear,rho,time 14 | END TYPE particle 15 | 16 | TYPE (particle), DIMENSION(:), ALLOCATABLE :: parti 17 | REAL(kind=rc_kind) :: dz,swap1,swap2,swap3 18 | INTEGER,ALLOCATABLE :: file_id(:) 19 | INTEGER :: NPR_eachfile 20 | CHARACTER(len=3) :: file_id_char 21 | 22 | PRIVATE :: NPR_eachfile, file_id_char, dz, swap1, swap2, swap3, 23 | file_id 24 | PUBLIC :: parti 25 | 26 | CONTAINS 27 | 28 | SUBROUTINE open_parti_files() 29 | IMPLICIT NONE 30 | INTEGER :: fi 31 | 32 | ALLOCATE (file_id(parti_file_num)) 33 | IF (MOD(NPR,parti_file_num) .NE. 0) THEN 34 | PRINT*, "Error: Please make sure NPR/file_num = integer in 35 | mod_particles.f90" 36 | PRINT*, "Stop model" 37 | STOP 38 | ENDIF 39 | 40 | NPR_eachfile = NPR/parti_file_num !the particle number in each file 41 | ! PRINT*, "# each file contains ",NPR_eachfile,"particles" 42 | 43 | !open files 44 | DO fi = 1, parti_file_num 45 | WRITE(file_id_char,'(I3.3)') fi 46 | file_id(fi) = 2000 + fi 47 | OPEN(file_id(fi), file = 48 | TRIM(dirout)//'op.parti-'//file_id_char//'.bin', & 49 | &form = 'unformatted', access = 'stream', status = 'replace') 50 | ! PRINT*, "open file 51 | ! "//TRIM(dirout)//'op.parti-'//file_id_char//'.bin' 52 | ENDDO 53 | 54 | END SUBROUTINE open_parti_files 55 | 56 | SUBROUTINE save_parti() 57 | IMPLICIT NONE 58 | INTEGER :: i_file,i 59 | 60 | PRINT*,"SAVE PARTICLES" 61 | SELECT CASE(0) 62 | CASE (0) 63 | !save limited variables 64 | DO i_file = 1, parti_file_num 65 | DO i = (i_file - 1) * NPR_eachfile + 1, i_file * NPR_eachfile 66 | WRITE(file_id(i_file)) parti(i)%i, & 67 | parti(i)%j, & 68 | parti(i)%k, & 69 | parti(i)%z, & 70 | !parti(i)%u, & 71 | !parti(i)%v, & 72 | parti(i)%w, & 73 | parti(i)%rho, & 74 | !parti(i)%s, & 75 | !parti(i)%t, & 76 | parti(i)%vor, & 77 | parti(i)%shear, & 78 | parti(i)%strain 79 | ENDDO 80 | ENDDO 81 | 82 | END SELECT 83 | 84 | END SUBROUTINE save_parti 85 | 86 | 87 | SUBROUTINE ini_particles(time) 88 | IMPLICIT NONE 89 | INTEGER :: i,j,k,time,itmp,npr_eachline 90 | REAL(kind=rc_kind) :: rand,r,theta, x1, y1 91 | INTEGER,PARAMETER :: seed = 86456 92 | 93 | ! PRINT*, "initialize files to save particles" 94 | CALL open_parti_files() 95 | 96 | CALL RANDOM_SEED() 97 | 98 | ! PRINT*, "# ini particles' velocities",NPR 99 | DO i=1, NPR 100 | parti(i)%time = DBLE(time) 101 | parti(i)%u0=0d0 102 | parti(i)%v0=0d0 103 | parti(i)%w0=0d0 104 | parti(i)%u=0d0 105 | parti(i)%v=0d0 106 | parti(i)%w=0d0 107 | parti(i)%t=0d0 108 | parti(i)%s=0d0 109 | parti(i)%rho=0d0 110 | parti(i)%vor=0d0 111 | parti(i)%shear=0d0 112 | parti(i)%strain=0d0 113 | ENDDO 114 | ! PRINT*, "# finish intial particles' velocities" 115 | 116 | DO i=1, NPR 117 | parti(i)%i=REAL(i*REAL(NI)/REAL(NPR)) 118 | parti(i)%j=90. 119 | parti(i)%k=2. 120 | ENDDO 121 | 122 | END SUBROUTINE ini_particles 123 | 124 | 125 | SUBROUTINE get_parti_vel(time) 126 | IMPLICIT NONE 127 | INTEGER :: i,j,k,ip,ic,jc,kc,ifc,jfc,kfc,time 128 | REAL(kind=rc_kind) :: dic,djc,dkc,dif,djf,dkf 129 | REAL(kind=rc_kind), DIMENSION( 0:NI,0:NJ+1 ) :: uxf 130 | REAL(kind=rc_kind), DIMENSION( 0:NI+1,0:NJ ) :: vyf 131 | REAL(kind=rc_kind), DIMENSION( 0:NI+1,0:NJ+1,0:NK ) :: wzf 132 | REAL(kind=rc_kind), DIMENSION( NI, 0:NJ, NK) :: vfp 133 | REAL(kind=rc_kind), DIMENSION( 0:NI+1,0:NJ, 0:NK+1) :: 134 | vf_ex 135 | REAL(kind=rc_kind), DIMENSION( 0:NI, NJ, NK) :: ufp 136 | REAL(kind=rc_kind), DIMENSION( 0:NI, 0:NJ+1, 0:NK+1) :: 137 | uf_ex 138 | REAL(kind=rc_kind), DIMENSION( NI, NJ, 0:NK) :: wfp 139 | REAL(kind=rc_kind), DIMENSION( 0:NI+1,0:NJ+1, 0:NK) :: 140 | wf_ex 141 | 142 | !rearrange the ux and vy to face grids 143 | !uxf = 0.5d0*(ux(0:NI,:)+ux(1:NI+1,:)) 144 | !vyf = 0.5d0*(vy(:,0:NJ)+vy(:,1:NJ+1)) 145 | wzf = 0.5d0*(wz(:,:,0:NK) + wz(:,:,1:NK+1)) 146 | 147 | !calculate the face velocity 148 | k=0 149 | wfp(:,:,k) = wf(:,:,k)/J2d(1:NI,1:NJ)*wzf(1:NI,1:NJ,k) 150 | 151 | DO k = 1, NK 152 | ufp(:,:,k) = uf(:,:,k)/Jifc(:,:,k) 153 | vfp(:,:,k) = vf(:,:,k)/Jjfc(:,:,k) 154 | wfp(:,:,k) = wf(:,:,k)/J2d(1:NI,1:NJ)*wzf(1:NI,1:NJ,k) 155 | ENDDO 156 | uf_ex=0d0 157 | uf_ex(:,1:NJ,1:NK) = ufp 158 | !=== vertical extrapolation 159 | uf_ex(:,:,NK+1) = 2*uf_ex(:,:,NK)-uf_ex(:,:,NK-1) ! extrapolation 160 | 161 | vf_ex=0d0 162 | vf_ex(1:NI,:,1:NK) = vfp 163 | !=== zonally periodic 164 | vf_ex(0,:,:) = vf_ex(NI,:,:) 165 | vf_ex(NI+1,:,:)=vf_ex(1,:,:) 166 | !=== vertical extrapolation 167 | vf_ex(:,:,NK+1) = 2*vf_ex(:,:,NK)-vf_ex(:,:,NK-1) 168 | 169 | wf_ex=0d0 170 | wf_ex(1:NI,1:NJ,:) = wfp 171 | !===zonal periodic condition 172 | wf_ex(0,:,:) = wf_ex(NI,:,:) 173 | wf_ex(NI+1,:,:) = wf_ex(1,:,:) 174 | !=== 175 | DO ip = 1, NPR 176 | parti(ip)%time=DBLE(time) 177 | IF (parti(ip)%j < NJ .AND. parti(ip)%j > 0 .AND. & 178 | parti(ip)%k < NK .AND. parti(ip)%k > 0) THEN 179 | !ic, jc, kc, is the integer index of the particle relative to 180 | !the grids center. Use these values for variables with the 181 | !ghost points. 182 | !ifc, jfc, and kfc is the index relative to the coordinates of 183 | !grid faces. 184 | !Use these values for variables on faces. 185 | ic = INT(parti(ip)%i+0.5d0) 186 | jc = INT(parti(ip)%j+0.5d0) 187 | kc = INT(parti(ip)%k+0.5d0) 188 | 189 | ifc = INT(parti(ip)%i) 190 | jfc = INT(parti(ip)%j) 191 | kfc = INT(parti(ip)%k) 192 | 193 | dif = parti(ip)%i - ifc 194 | djf = parti(ip)%j - jfc 195 | dkf = parti(ip)%k - kfc 196 | 197 | !call sigma2z(ifc,jfc,parti(ip)%k,parti(ip)%z) 198 | !dzf is the normalized distance of a particle to bottom faces. 199 | !dzf = (parti(ip)%z - zf(ifc,jfc,kfc)) / ( zf(ifc,jfc,kfc+1) - 200 | !zf(ifc,jfc,kfc) ) 201 | 202 | dic = parti(ip)%i - ic + 0.5d0 203 | djc = parti(ip)%j - jc + 0.5d0 204 | dkc = parti(ip)%k - kc + 0.5d0 205 | !calcuate the zonal velocity 206 | CALL 207 | Csigma2z(parti(ip)%i,parti(ip)%j+0.5d0,parti(ip)%k+0.5,swap1) 208 | CALL sigma2z(parti(ip)%i,parti(ip)%j+0.5d0,dble(kc),swap2) 209 | CALL sigma2z(parti(ip)%i,parti(ip)%j+0.5d0,dble(kc+1),swap3) 210 | dz = (swap1 - swap2) / ( swap3 - swap2 ) 211 | 212 | CALL 213 | Cinterp_trilinear(dif,djc,dz,uf_ex(ifc:ifc+1,jc:jc+1,kc:kc+1),parti(ip)%u) 214 | !CALL 215 | !interp_trilinear(dif,djc,dkc,uf_ex(ifc:ifc+1,jc:jc+1,kc:kc+1),parti(ip)%u) 216 | 217 | !calcuate the meridional velocity 218 | CALL 219 | Csigma2z(parti(ip)%i+0.5d0,parti(ip)%j,parti(ip)%k+0.5d0,swap1) 220 | CALL sigma2z(parti(ip)%i+0.5d0,parti(ip)%j,dble(kc),swap2) 221 | CALL sigma2z(parti(ip)%i+0.5d0,parti(ip)%j,dble(kc+1),swap3) 222 | dz = (swap1 - swap2) / ( swap3 - swap2 ) 223 | CALL 224 | Cinterp_trilinear(dic,djf,dz,vf_ex(ic:ic+1,jfc:jfc+1,kc:kc+1),parti(ip)%v) 225 | !CALL 226 | !interp_trilinear(dic,djf,dkc,vf_ex(ic:ic+1,jfc:jfc+1,kc:kc+1),parti(ip)%v) 227 | 228 | !calcuate the vertical velocity 229 | CALL sigma2z(parti(ip)%i,parti(ip)%j,parti(ip)%k,swap1) 230 | CALL sigma2z(parti(ip)%i,parti(ip)%j,dble(kfc),swap2) 231 | CALL sigma2z(parti(ip)%i,parti(ip)%j,dble(kfc+1),swap3) 232 | dz = (swap1 - swap2) / ( swap3 - swap2 ) 233 | parti(ip)%z=swap1*DL 234 | CALL 235 | Cinterp_trilinear(dic,djc,dz,wf_ex(ic:ic+1,jc:jc+1,kfc:kfc+1),parti(ip)%w) 236 | !CALL 237 | !interp_trilinear(dic,djc,dkf,wf_ex(ic:ic+1,jc:jc+1,kfc:kfc+1),parti(ip)%w) 238 | 239 | !diagnose other properties 240 | CALL 241 | Csigma2z(parti(ip)%i+0.5d0,parti(ip)%j+0.5d0,parti(ip)%k+0.5d0,swap1) 242 | CALL 243 | Csigma2z(parti(ip)%i+0.5d0,parti(ip)%j+0.5d0,dble(kc),swap2) 244 | CALL 245 | Csigma2z(parti(ip)%i+0.5d0,parti(ip)%j+0.5d0,dble(kc+1),swap3) 246 | dz = (swap1 - swap2) / ( swap3 - swap2 ) 247 | 248 | CALL 249 | Cinterp_trilinear(dic,djc,dz,vor(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%vor) 250 | CALL 251 | Cinterp_trilinear(dic,djc,dz,rho(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%rho) 252 | CALL 253 | Cinterp_trilinear(dic,djc,dz,shear(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%shear) 254 | CALL 255 | Cinterp_trilinear(dic,djc,dz,strain(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%strain) 256 | !!$ if (ip == 8001) then 257 | !!$ print*, 'dkc,dz=',dkc,dz 258 | !!$ print*, 'dic,djc',dic,djc 259 | !!$ Print*, 'rho=',rho(ic:ic+1,jc:jc+1,kc:kc+1) 260 | !!$ print*, 'parti(ip)rho=',parti(ip)%rho 261 | !!$ endif 262 | !CALL 263 | !interp_trilinear(dic,djc,dkc,vor(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%vor) 264 | !CALL 265 | !interp_trilinear(dic,djc,dkc,s(ic:ic+1,jc:jc+1,kc:kc+1,0),parti(ip)%vor) 266 | !CALL 267 | !interp_trilinear(dic,djc,dkc,shear(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%shear) 268 | !CALL 269 | !interp_trilinear(dic,djc,dkc,strain(ic:ic+1,jc:jc+1,kc:kc+1),parti(ip)%strain) 270 | !parti(ip)%shear = dz 271 | !parti(ip)%strain = dkc 272 | !parti(ip)%r = rho(ic:ic+1,jc:jc+1,kc:kc+1) 273 | 274 | ELSE 275 | parti(ip)%u=0d0 276 | parti(ip)%v=0d0 277 | parti(ip)%w=0d0 278 | ENDIF 279 | ENDDO 280 | ! get the zonal velocity u 281 | 282 | END SUBROUTINE get_parti_vel 283 | 284 | SUBROUTINE parti_forward() 285 | IMPLICIT NONE 286 | INTEGER :: i 287 | DO i = 1, NPR 288 | parti(i)%i = parti(i)%i + 0.5d0 * dtf * (3d0 * parti(i)%u - 289 | parti(i)%u0) 290 | IF (parti(i)%i >NI) parti(i)%i = parti(i)%i - REAL(NI) 291 | IF (parti(i)%i <0d0 ) parti(i)%i = parti(i)%i + REAL(NI) 292 | 293 | IF (parti(i)%j>NJ-1 .AND. parti(i)%v>0) THEN 294 | parti(i)%j = parti(i)%j + parti(i)%v * dtf / (1d0 + 295 | (parti(i)%v * dtf)/(DBLE(NJ) - parti(i)%j) ) 296 | ELSE IF (parti(i)%j<1 .AND. parti(i)%v<0) THEN 297 | parti(i)%j = parti(i)%j + parti(i)%v * dtf / ( 1d0 - 298 | dtf/parti(i)%j ) 299 | ELSE 300 | parti(i)%j = parti(i)%j + 0.5d0 * dtf * (3d0 * parti(i)%v - 301 | parti(i)%v0) 302 | ENDIF 303 | 304 | IF (parti(i)%k>NK-1 .AND. parti(i)%w>0) THEN 305 | parti(i)%k = parti(i)%k + parti(i)%w * dtf / (1d0 + 306 | (parti(i)%w * dtf)/(DBLE(NK) - parti(i)%k) ) 307 | ELSE IF (parti(i)%k<1 .AND. parti(i)%w<0) THEN 308 | parti(i)%k = parti(i)%k + parti(i)%w * dtf / ( 1d0 - 309 | dtf/parti(i)%k ) 310 | ELSE 311 | parti(i)%k = parti(i)%k + 0.5d0 * dtf * (3d0 * parti(i)%w - 312 | parti(i)%w0) 313 | ENDIF 314 | 315 | !debug part 316 | IF (parti(i)%j<0d0 .OR. parti(i)%j>NJ .OR. parti(i)%k>NK .OR. 317 | parti(i)%k<0d0 ) THEN 318 | PRINT*, "particles coordinates are wrong, 319 | iPR=",i,"j,k",parti(i)%j,parti(i)%k 320 | !stop 321 | ENDIF 322 | 323 | parti(i)%u0 = parti(i)%u 324 | parti(i)%v0 = parti(i)%v 325 | parti(i)%w0 = parti(i)%w 326 | ENDDO 327 | 328 | END SUBROUTINE parti_forward 329 | 330 | 331 | SUBROUTINE interp_trilinear(di,dj,dk,var,velp) 332 | !== give 8 corner points of a cube, interpolate point values inside 333 | !of the cube 334 | !== di is the distance between the particle to the left face 335 | !== dj is the distance between the particle to the southern face 336 | !== dk is the distance between the particle and the bottom face 337 | IMPLICIT NONE 338 | REAL(kind=rc_kind), INTENT(in) :: di,dj,dk 339 | REAL(kind=rc_kind), INTENT(in), DIMENSION( 2, 2 , 2 ) 340 | :: var 341 | REAL(kind=rc_kind), INTENT(out) :: velp 342 | REAL(kind=rc_kind) :: i1,i2,i3,i4,j1,j2,ti,tj,tk 343 | 344 | ! calcuate the Trilinear interpolation 345 | i1 = (var(2,1, 1) - var(1,1, 1))*di + var(1,1, 1) 346 | i2 = (var(2,1, 2) - var(1,1,2))*di + var(1,1, 2) 347 | i3 = (var(2,2,2) - var(1,2,2))*di +var(1,2,2) 348 | i4 = (var(2,2,1) - var(1,2,1))*di + var(1,2,1) 349 | 350 | j1 = (i3 - i2)*dj + i2 351 | j2 = (i4 - i1)*dj + i1 352 | 353 | velp = (j1 - j2) * dk + j2 354 | !print*, 'dz,j1,j2,velp=',dk,j1,j2,velp 355 | END SUBROUTINE interp_trilinear 356 | 357 | SUBROUTINE get_parti_vel_ana() 358 | INTEGER :: ip 359 | DO ip = 1, NPR 360 | parti(ip)%u = 361 | -1*SIN(pi*parti(ip)%i/REAL(NI))*COS(pi*parti(ip)%j/REAL(NJ)) 362 | parti(ip)%v = 363 | COS(pi*parti(ip)%i/REAL(NI))*SIN(pi*parti(ip)%j/REAL(NJ)) 364 | ENDDO 365 | END SUBROUTINE get_parti_vel_ana 366 | 367 | 368 | END MODULE particles 369 | 370 | #endif 371 | -------------------------------------------------------------------------------- /src/io.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE load_z_lookup_table() 2 | #include "cpp_options.h" 3 | 4 | #ifdef use_mixedlayer_shuffle 5 | USE global, ONLY: z2k,k2z,path2uvw 6 | IMPLICIT NONE 7 | REAL*4::tmp(5701),tmp1(0:1040) 8 | OPEN(63,file='../data/z_to_k_lookup_table.bin',& 9 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 10 | status='old',recl=4*5701) 11 | READ(63,rec=1) tmp 12 | z2k=REAL(tmp,8) 13 | CLOSE(63) 14 | 15 | OPEN(64,file='../data/k_to_z_lookup_table.bin',& 16 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 17 | status='old',recl=4*421) 18 | READ(64,rec=1) tmp1 19 | k2z=REAL(tmp1,8) 20 | CLOSE(64) 21 | #endif 22 | 23 | END SUBROUTINE load_z_lookup_table 24 | 25 | SUBROUTINE load_mld(tt) 26 | #include "cpp_options.h" 27 | #ifdef use_mixedlayer_shuffle 28 | USE global, ONLY: Nx,Ny,dt_mld,tend_file,fn_id_mld,mld 29 | REAL*8, INTENT(in) :: tt 30 | INTEGER*8 :: i 31 | 32 | OPEN(fn_id_mld,file=TRIM(path2uvw)//TRIM(fn_MLD),& 33 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 34 | status='old',recl=4*Nx*Ny) 35 | 36 | i=INT(MOD(tt,tend_file)/dt_mld)+1 37 | PRINT*, "load mixed layer depth data at time ",tt, "and step", i 38 | READ(fn_id_mld,rec=i) mld(0:Nx-1,0:Ny-1) 39 | 40 | mld(-2:-1,:) = mld(Nx-2:Nx-1,:) 41 | mld(Nx:Nx+1,:)=mld(0:1,:) 42 | 43 | CLOSE(fn_id_mld) 44 | 45 | #endif 46 | 47 | END SUBROUTINE load_mld 48 | 49 | 50 | SUBROUTINE load_PHIHYD(tt) 51 | 52 | USE global, ONLY: Nx,Ny,dt_mld,tend_file,fn_uvwtsg_ids,phihyd 53 | REAL*8, INTENT(in) :: tt 54 | INTEGER*8 :: i 55 | 56 | i=INT(MOD(tt,tend_file)/dt_mld)+1 57 | PRINT*, "load PHIHYD data at time ",tt, "and step", i 58 | READ(fn_uvwtsg_ids(7),rec=i) phihyd(0:Nx-1,0:Ny-1) 59 | 60 | phihyd(-2:-1,:) = phihyd(Nx-2:Nx-1,:) 61 | phihyd(Nx:Nx+1,:)=phihyd(0:1,:) 62 | 63 | END SUBROUTINE load_PHIHYD 64 | 65 | 66 | SUBROUTINE load_3d(fn_id,irec,dout,read_flag) 67 | #include "cpp_options.h" 68 | 69 | USE global, ONLY : Nx,Ny,Nz,Nrecs,xyz 70 | IMPLICIT NONE 71 | INTEGER*8, INTENT(in) :: irec,fn_id,read_flag 72 | REAL*4, DIMENSION(-2:Nx+1,0:Ny-1,-1:Nz), INTENT(out) :: dout 73 | INTEGER*8 :: i=0,k=0,k0=0,k1=0 74 | 75 | i=MOD(irec,Nrecs) 76 | IF (i .EQ. 0) THEN 77 | i=Nrecs 78 | ENDIF 79 | 80 | i=(i-1)*Nz+1 81 | !selectively reading data from k0 to k1 levels 82 | IF (read_flag==1) THEN 83 | k0=MAX(MINVAL(FLOOR(xyz(:,3,:)))-1,0) 84 | k1=MIN(MAXVAL(CEILING(xyz(:,3,:)))+1,Nz-1) 85 | ELSE 86 | k0=0 87 | k1=Nz-1 88 | ENDIF 89 | 90 | !$OMP PARALLEL DO PRIVATE(k) 91 | !do k=k0,k1 92 | DO k=0,Nz-1 93 | READ(fn_id,rec=i+k) dout(0:Nx-1,:,k) 94 | !dout(Nx:Nx+1,:,k)=dout(0:1,:,k) 95 | !dout(-2:-1,:,k)=dout(Nx-2:Nx-1,:,k) 96 | ENDDO 97 | !$OMP END PARALLEL DO 98 | END SUBROUTINE load_3d 99 | 100 | SUBROUTINE load_uvw(irec,isw) 101 | 102 | USE global, ONLY : fn_uvwtsg_ids,Nx,Ny,Nz,uu,vv,ww,theta,gam,salt,Nrecs,& 103 | fn_UVEL,fn_VVEL,fn_WVEL,path2uvw,filenames 104 | IMPLICIT NONE 105 | INTEGER*8, INTENT(in) :: irec,isw 106 | !real*4, dimension(-1:Nx+1,0:Ny-1,-1:Nz) :: tmp 107 | INTEGER*8 :: i,ifile,ii,read_flag 108 | 109 | read_flag=1 ! 1--> read all vertical levels, selective otherwise 110 | 111 | #ifdef monitoring 112 | PRINT*, "----load uvw at irec,mod(irec,Nrecs),iswitch",irec,mod(irec,Nrecs),isw 113 | #endif 114 | 115 | 116 | #ifdef one_file_per_step 117 | ifile=MOD(irec,Nrecs) !gives the index of the filename 118 | IF (ifile .EQ. 0) THEN 119 | ifile=Nrecs 120 | ENDIF 121 | i=1 !always read the first record if the file only contains one step 122 | #else 123 | 124 | ifile=1 !if all records are saved in one file, the program always reads filename(1,i) 125 | 126 | #ifdef stationary_velocity 127 | i=1 128 | #else 129 | i=MOD(irec,Nrecs) 130 | IF (i .EQ. 0) THEN 131 | i=Nrecs 132 | ENDIF 133 | #endif 134 | 135 | 136 | #endif 137 | 138 | !$OMP PARALLEL SECTIONS 139 | !$OMP SECTION 140 | 141 | #ifdef monitoring 142 | PRINT*, ifile,TRIM(path2uvw)//TRIM(filenames(ifile,1)) 143 | #endif 144 | 145 | #ifdef isArgo 146 | DO ii = 1, 2 147 | #else 148 | DO ii = 1, 3 149 | #endif 150 | 151 | OPEN(fn_uvwtsg_ids(ii),file=TRIM(path2uvw)//TRIM(filenames(ifile,ii)),& 152 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 153 | status='old',recl=4*Nx*Ny) 154 | ENDDO 155 | 156 | 157 | #ifdef monitoring 158 | PRINT*, "next load ",TRIM(path2uvw)//TRIM(filenames(ifile,1)) 159 | #endif 160 | 161 | CALL load_3d(fn_uvwtsg_ids(1),i,uu(:,0:Ny-1,:,isw),read_flag) 162 | uu(:,:,-1,isw)=uu(:,:,0,isw) 163 | uu(:,:,Nz,isw)=uu(:,:,Nz-1,isw) 164 | #ifdef periodic_x 165 | uu(-2:-1,:,:,isw)=uu(Nx-2:Nx-1,:,:,isw) 166 | uu(Nx:Nx+1,:,:,isw)=uu(0:1,:,:,isw) 167 | #endif 168 | 169 | #ifdef monitoring 170 | PRINT*, "next load ",TRIM(path2uvw)//TRIM(filenames(ifile,2)) 171 | #endif 172 | !$OMP SECTION 173 | CALL load_3d(fn_uvwtsg_ids(2),i,vv(:,0:Ny-1,:,isw),read_flag) 174 | vv(:,:,-1,isw)=vv(:,:,0,isw) 175 | vv(:,:,Nz,isw)=vv(:,:,Nz-1,isw) 176 | #ifdef reflective_meridional_boundary 177 | vv(:,Ny:Ny+1,:,isw) = -1d0 178 | vv(:,-2:-1,:,isw) = 1d0 179 | #endif 180 | #ifdef periodic_x 181 | vv(-2:-1,:,:,isw)=vv(Nx-2:Nx-1,:,:,isw) 182 | vv(Nx:Nx+1,:,:,isw)=vv(0:1,:,:,isw) 183 | #endif 184 | 185 | !$OMP SECTION 186 | #ifdef monitoring 187 | PRINT*, "next load ",TRIM(path2uvw)//TRIM(filenames(ifile,3)) 188 | #endif 189 | #ifndef isArgo 190 | CALL load_3d(fn_uvwtsg_ids(3),i,ww(:,0:Ny-1,:,isw),read_flag) 191 | ww(:,:,-1,isw)=-1d-5 !reflective surface ghost cell 192 | ww(:,:,Nz,isw)=1d-5 !reflective bottom ghost cell 193 | #ifdef periodic_x 194 | ww(-2:-1,:,:,isw)=ww(Nx-2:Nx-1,:,:,isw) 195 | ww(Nx:Nx+1,:,:,isw)=ww(0:1,:,:,isw) 196 | #endif 197 | #endif 198 | 199 | #ifdef monitoring 200 | PRINT*, "====>> load VVEL", irec, "min() =", MINVAL(vv(:,:,:,isw)) 201 | PRINT*, "====>> load VVEL", irec, "max() =", MAXVAL(vv(:,:,:,isw)) 202 | PRINT*, "====>> load UVEL", irec, "min() =", MINVAL(uu(:,:,:,isw)) 203 | PRINT*, "====>> load UVEL", irec, "max() =", MAXVAL(uu(:,:,:,isw)) 204 | PRINT*, "====>> load WVEL", irec, "min() =", MINVAL(ww(:,:,:,isw)) 205 | PRINT*, "====>> load WVEL", irec, "max() =", MAXVAL(ww(:,:,:,isw)) 206 | #endif 207 | 208 | !$OMP END PARALLEL SECTIONS 209 | 210 | DO ii = 1, 3 211 | CLOSE(fn_uvwtsg_ids(ii)) 212 | ENDDO 213 | 214 | END SUBROUTINE load_uvw 215 | 216 | 217 | SUBROUTINE load_tsg(irec,isw) 218 | #include "cpp_options.h" 219 | 220 | #ifdef saveTSG 221 | #ifndef isArgo 222 | 223 | USE global, ONLY : fn_uvwtsg_ids,Nx,Ny,Nz,uu,path2uvw,filenames,& 224 | vv,ww,theta,gam,salt,Nrecs,fn_GAMMA 225 | 226 | IMPLICIT NONE 227 | INTEGER*8, INTENT(in) :: irec,isw 228 | !real*4, dimension(-1:Nx+1,0:Ny-1,-1:Nz) :: tmp 229 | INTEGER*8 :: i,ifile,ii,read_flag 230 | 231 | read_flag=1 ! 1 : read all vertical levels, selective otherwise 232 | 233 | #ifdef one_file_per_step 234 | ifile=MOD(irec,Nrecs) 235 | IF (ifile .EQ. 0) THEN 236 | ifile=Nrecs 237 | ENDIF 238 | i=1 !always read the first record if the file only contains one step 239 | #else 240 | i=MOD(irec,Nrecs) 241 | IF (i .EQ. 0) THEN 242 | i=Nrecs 243 | ENDIF 244 | ifile=1 245 | #endif 246 | 247 | DO ii = 4, 5 248 | OPEN(fn_uvwtsg_ids(ii),file=TRIM(path2uvw)//TRIM(filenames(ifile,ii)),& 249 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 250 | status='old',recl=4*Nx*Ny) 251 | ENDDO 252 | 253 | !$OMP PARALLEL SECTIONS 254 | !$OMP SECTION 255 | CALL load_3d(fn_uvwtsg_ids(4),i,theta(:,:,:,isw),read_flag) 256 | theta(:,:,-1,isw)=theta(:,:,0,isw) 257 | theta(:,:,Nz,isw)=theta(:,:,Nz-1,isw) 258 | PRINT*, "====>> load THETA", irec, "min() =", MINVAL(theta(:,:,:,isw)),MAXVAL(theta(:,:,:,isw)) 259 | 260 | !$OMP SECTION 261 | CALL load_3d(fn_uvwtsg_ids(5),i,salt(:,:,:,isw),read_flag) 262 | 263 | salt(:,:,-1,isw)=salt(:,:,0,isw) 264 | salt(:,:,Nz,isw)=salt(:,:,Nz-1,isw) 265 | 266 | PRINT*, "====>> load SALT", i, "min() =", MINVAL(salt(:,:,:,isw)),MAXVAL(salt(:,:,:,isw)) 267 | 268 | 269 | #ifndef isGlider 270 | !$OMP SECTION 271 | IF (fn_GAMMA .EQ. '') THEN 272 | gam=0 273 | ELSE 274 | CALL load_3d(fn_uvwtsg_ids(6),i,gam(:,:,:,isw),read_flag) 275 | 276 | gam(:,:,-1,isw)=gam(:,:,0,isw) 277 | gam(:,:,Nz,isw)=gam(:,:,Nz-1,isw) 278 | 279 | WHERE(gam(:,:,:,isw)<20) gam(:,:,:,isw)=0d0 280 | ENDIF 281 | 282 | PRINT*, "====>> load GAMMA", irec, "min() =", MINVAL(gam(:,:,:,isw)) 283 | 284 | #endif 285 | 286 | 287 | !$OMP END PARALLEL SECTIONS 288 | 289 | 290 | PRINT*, "end loading data" 291 | 292 | DO ii = 4, 6 293 | CLOSE(fn_uvwtsg_ids(ii)) 294 | ENDDO 295 | 296 | #endif 297 | #endif 298 | 299 | 300 | END SUBROUTINE load_tsg 301 | 302 | 303 | SUBROUTINE load_grid() 304 | #include "cpp_options.h" 305 | 306 | USE global, ONLY : dxg_r,dyg_r,drf_r,Nx,Ny,Nz,hFacC,path2grid!,hFacS,hFacW 307 | 308 | IMPLICIT NONE 309 | REAL*4 :: tmp(0:Nx-1,0:Ny-1),tmp1(0:Nz-1) 310 | 311 | PRINT*, "=================================================" 312 | PRINT*, "loading grid ......... " 313 | 314 | OPEN(91,file=TRIM(path2grid)//'DXG.data',& 315 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 316 | status='old',recl=4*Nx*Ny) 317 | READ(91,rec=1) tmp 318 | dxg_r(0:Nx-1,0:Ny-1)=REAL(tmp,8) 319 | dxg_r(Nx:Nx+1,:)=dxg_r(0:1,:) 320 | dxg_r(-2:-1,:)=dxg_r(Nx-2:Nx-1,:) 321 | dxg_r = 1.0/dxg_r 322 | CLOSE(91) 323 | 324 | OPEN(92,file=TRIM(path2grid)//'DYG.data',& 325 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 326 | status='old',recl=4*Nx*Ny) 327 | READ(92,rec=1) tmp 328 | dyg_r(0:Nx-1,0:Ny-1)=REAL(tmp,8) 329 | dyg_r(Nx:Nx+1,:)=dyg_r(0:1,:) 330 | dyg_r(-2:-1,:)=dyg_r(Nx-2:Nx-1,:) 331 | dyg_r = 1.0/dyg_r 332 | CLOSE(92) 333 | 334 | OPEN(93,file=TRIM(path2grid)//'DRF.data',& 335 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 336 | status='old',recl=4*Nz) 337 | READ(93,rec=1) tmp1 338 | drf_r(0:Nz-1)=REAL(tmp1,8) 339 | drf_r(-1)=drf_r(0) 340 | drf_r(Nz)=drf_r(Nz-1) 341 | drf_r = 1.0/drf_r 342 | CLOSE(93) 343 | 344 | #ifndef isArgo 345 | OPEN(94,file=TRIM(path2grid)//'hFacC.data',& 346 | form='unformatted',access='direct',convert='BIG_ENDIAN',& 347 | status='old',recl=4*Nz*Ny*Nx) 348 | READ(94,rec=1) hFacC(0:Nx-1,0:Ny-1,0:Nz-1) 349 | hFacC(Nx:Nx+1,:,:)=hFacC(0:1,:,:) 350 | hFacC(-2:-1,:,:)=hFacC(Nx-2:Nx-1,:,:) 351 | hFacC(:,:,-1)=hFacC(:,:,0) 352 | hFacC(:,:,Nz)=0d0 353 | CLOSE(94) 354 | #endif 355 | 356 | END SUBROUTINE load_grid 357 | 358 | 359 | SUBROUTINE save_data(IPP) 360 | #include "cpp_options.h" 361 | !output particle data 362 | USE omp_lib 363 | USE global 364 | 365 | IMPLICIT NONE 366 | CHARACTER(len=128) :: fn 367 | CHARACTER(len=16) :: fn1 368 | INTEGER*8 :: iwrite,ip 369 | INTEGER*8,INTENT(in) :: IPP 370 | 371 | iwrite=INT(tt/DumpClock) 372 | 373 | WRITE(fn,"(I10.10)") iwrite 374 | WRITE(fn1,"(I4.4)") IPP 375 | 376 | #ifdef saveArgoProfile 377 | do ip=1,Npts 378 | if (argo_clock(ip,1,IPP)==4) then 379 | WRITE(save_argo_profileIDs(ip,ipp),rec=argoprofilerec) real(tt,4),real(xyz(ip,:,ipp),4),real(tsg(ip,1:2,ipp),4) 380 | argoprofilerec=argoprofilerec+1 381 | call flush(save_argo_profileIDs(ip,ipp)) 382 | if (ip==1 .and. ipp==1) then 383 | print*, real(xyz(ip,:,ipp),4),real(uvwp(ip,:,ipp)),pi2c(ip,ipp),pj2c(ip,ipp),pk2c(ip,ipp) 384 | endif 385 | 386 | endif 387 | enddo 388 | #else 389 | 390 | !$OMP PARALLEL SECTIONS 391 | 392 | !$OMP SECTION 393 | OPEN(fn_ids(1,IPP),file=TRIM(output_dir)//'/'//TRIM(casename)//'_'//TRIM(fn1)//'.XYZ.'//TRIM(fn)//'.data',& 394 | access='direct',form='unformatted', convert='BIG_ENDIAN',recl=3*4*Npts,status='unknown') 395 | WRITE(fn_ids(1,IPP),rec=1) REAL(xyz(:,:,IPP),4) 396 | CLOSE(fn_ids(1,IPP)) 397 | 398 | #ifdef saveTSG 399 | !$OMP SECTION 400 | OPEN(fn_ids(2,IPP),file=TRIM(output_dir)//'/'//TRIM(casename)//'_'//TRIM(fn1)//'.TSG.'//TRIM(fn)//'.data',& 401 | access='direct',form='unformatted',convert='BIG_ENDIAN',recl=4*4*Npts,status='unknown') 402 | WRITE(fn_ids(2,IPP),rec=1) REAL(tsg(:,:,IPP),4) 403 | CLOSE(fn_ids(2,IPP)) 404 | 405 | #endif 406 | 407 | #ifdef use_mixedlayer_shuffle 408 | !$OMP SECTION 409 | OPEN(fn_ids(3,IPP),file=TRIM(output_dir)//'/'//TRIM(casename)//'_'//TRIM(fn1)//'.MLD.'//TRIM(fn)//'.data',& 410 | access='direct',form='unformatted',convert='BIG_ENDIAN',recl=4*Npts,status='unknown') 411 | WRITE(fn_ids(3,IPP),rec=1) REAL(parti_mld(:,IPP),4) 412 | CLOSE(fn_ids(3,IPP)) 413 | #endif 414 | 415 | #ifdef saveGradient 416 | !$OMP SECTION 417 | OPEN(fn_ids(4,IPP),file=TRIM(output_dir)//'/'//TRIM(casename)//'_'//TRIM(fn1)//'.GRAD.'//TRIM(fn)//'.data',& 418 | access='direct',form='unformatted', convert='BIG_ENDIAN',recl=5*4*Npts,status='unknown') 419 | WRITE(fn_ids(4,IPP),rec=1) REAL(grad(:,:,IPP),4) 420 | CLOSE(fn_ids(4,IPP)) 421 | #endif 422 | !$OMP END PARALLEL SECTIONS 423 | 424 | #endif 425 | 426 | 427 | END SUBROUTINE save_data 428 | 429 | 430 | SUBROUTINE save_glider_data(SNPP) 431 | #include "cpp_options.h" 432 | #ifdef isGlider 433 | USE global, ONLY :tt,saveFreq,Npts,& 434 | iswitch,count_step,& 435 | save_glider_FnIDs,glider_uv,glider_angle,& 436 | xyz,uvwp,tsg,theta 437 | 438 | IMPLICIT NONE 439 | INTEGER*8 :: i,IPP,t0,t1 440 | INTEGER*8, INTENT(in) :: SNPP 441 | 442 | t0=ABS(iswitch-1) 443 | t1=iswitch 444 | 445 | IF (MOD(count_step,saveFreq) .EQ. 0) THEN 446 | DO IPP=1,SNPP 447 | #ifdef saveTSG 448 | CALL interp_tracer(t0,t1,IPP) 449 | #endif 450 | DO i=1,Npts 451 | WRITE(save_glider_FnIDs(i,IPP),"(11F13.5)") tt, xyz(i,:,IPP),& 452 | tsg(i,1:2,IPP),uvwp(i,1:2,IPP),glider_uv(i,:,IPP),& 453 | glider_angle(i,IPP) 454 | ! if (i==2) then 455 | ! write(*,"(6F9.3)") xyz(i,:,IPP),tsg(i,1:2,IPP),theta(i,floor(xyz(i,2,IPP)),floor(xyz(i,3,IPP)),0) 456 | ! endif 457 | ENDDO 458 | ENDDO 459 | ENDIF 460 | 461 | #endif 462 | END SUBROUTINE save_glider_data 463 | --------------------------------------------------------------------------------