Back to OASIS3-MCT home

The models use mod_oasis and call the routines of the psmile. The routines of the psmile are sorted out below as they are called by the models.

In oasis3-mct/lib/psmile/src :

mod_oasis:  Main module of the psmile in OASIS3-MCT.
Called by the models to be able to use the routines allowing communication
with the other models of the coupling.
module mod_oasis
! !USES:
  USE mod_oasis_kinds  ,ONLY: ip_single_p
  USE mod_oasis_kinds  ,ONLY: ip_double_p
  USE mod_oasis_kinds  ,ONLY: ip_realwp_p
  USE mod_oasis_kinds  ,ONLY: ll_single
  USE mod_oasis_kinds  ,ONLY: ip_i2_p
  USE mod_oasis_kinds  ,ONLY: ip_i4_p
  USE mod_oasis_kinds  ,ONLY: ip_i8_p
  USE mod_oasis_kinds  ,ONLY: ip_intwp_p
  USE mod_oasis_parameters
  USE mod_oasis_namcouple ,ONLY: namflddti
  USE mod_oasis_method ,ONLY: oasis_init_comp   
  USE mod_oasis_method ,ONLY: oasis_terminate
  USE mod_oasis_method ,ONLY: oasis_get_localcomm
  USE mod_oasis_method ,ONLY: oasis_set_couplcomm
  USE mod_oasis_method ,ONLY: oasis_create_couplcomm
  USE mod_oasis_method ,ONLY: oasis_get_intracomm
  USE mod_oasis_method ,ONLY: oasis_get_intercomm
  USE mod_oasis_method ,ONLY: oasis_set_debug    
  USE mod_oasis_method ,ONLY: oasis_get_debug    
  USE mod_oasis_method ,ONLY: oasis_enddef       
  USE mod_oasis_part   ,ONLY: oasis_def_partition  
  USE mod_oasis_var    ,ONLY: oasis_def_var      
  USE mod_oasis_getput_interface ,ONLY: oasis_get
  USE mod_oasis_getput_interface ,ONLY: oasis_put  
  USE mod_oasis_grid   ,ONLY: oasis_start_grids_writing
  USE mod_oasis_grid   ,ONLY: oasis_write_grid
  USE mod_oasis_grid   ,ONLY: oasis_write_angle
  USE mod_oasis_grid   ,ONLY: oasis_write_corner       
  USE mod_oasis_grid   ,ONLY: oasis_write_mask         
  USE mod_oasis_grid   ,ONLY: oasis_write_area         
  USE mod_oasis_grid   ,ONLY: oasis_terminate_grids_writing  
  USE mod_oasis_auxiliary_routines, ONLY: oasis_get_ncpl
  USE mod_oasis_auxiliary_routines, ONLY: oasis_get_freqs
  USE mod_oasis_auxiliary_routines, ONLY: oasis_put_inquire
  USE mod_oasis_sys    ,ONLY: oasis_abort      

  IMPLICIT NONE

!===============================================================================
end module mod_oasis

oasis_init_comp (in mod_oasis_method): (mynummod,cdnam,kinfo,coupled) : no global structures
=> oasis_data_zero()
oasis_coupled = .true.
if (present(coupled)) then
    oasis_coupled = coupled
endif
=> call MPI_Initialized
=> call MPI_Comm_Size(mpi_comm_global,mpi_size_global,mpi_err)
=> call MPI_Comm_Rank(mpi_comm_global,mpi_rank_global,mpi_err)
=> oasis_unitsetmin(1024)
if (mpi_rank_global == 0) then
=> oasis_unitget (iu)   ! for the namcouple informations nout
=> oasis_namcouple_init()
=> oasis_unitget(nulin)  ! To open file namcouple
       open (UNIT = nulin,FILE =cl_namcouple,STATUS='OLD', FORM ='FORMATTED', IOSTAT = il_iost)
=> inipar_alloc()
=> parse
=> alloc()
=> inipar()
=> parse
close(nulin)
=> oasis_unitfree(nulin)
=> oasis_unitsetmin(maxunit) ! Maxunit : max of unit used by all the models read in the namcouple
=> dealloc()
endif
=> call oasis_mpi_barrier(mpi_comm_global)
if (mpi_rank_global /= 0) then
=> oasis_namcouple_init()
endif
OASIS_debug = namlogprt
size_namfld = size_namfld + oasis_string_listGetNum(namsrcfld(n))   ! number of line of coupling fields read in the namcouple
maxvar = size_namfld * 2    ! multiply by 2 to allow sending to self
nvar ! Store all the names of the fields exchanged in the namcouple (multiple fields)
! Set mpi_comm_local based on compid
ikey = 0
icolor = compid
=> call MPI_COMM_SPLIT (MPI_COMM_WORLD,icolor,ikey,mpi_comm_local,mpi_err) ! to get the mpi_comm_local of each model over all its procs
! Set mpi_comm_global based on oasis_coupled flag
ikey = 0
icolor = 1
if (.not.oasis_coupled) icolor = 0
=> call MPI_COMM_SPLIT(MPI_COMM_WORLD,icolor,ikey,mpi_comm_global,ierr)
if (.not.oasis_coupled) then
      return
endif
=> call MPI_Comm_Size(mpi_comm_global,mpi_size_global,mpi_err)
=> call MPI_Comm_Rank(mpi_comm_global,mpi_rank_global,mpi_err)
=> call MPI_Comm_Size(mpi_comm_local,mpi_size_local,mpi_err)
=> call MPI_Comm_Rank(mpi_comm_local,mpi_rank_local,mpi_err)
! Debug files
=> oasis_unitget(iu)  ! for the debug files
=> oasis_mpi_bcast
=> oasis_debug_enter(subname)
=> mod_oasis_setrootglobal()
nt = 7*maxvar+30
=> oasis_timer_init (trim(cdnam), trim(cdnam)//'.timers', nt)
=> oasis_timer_start('total')
=> oasis_timer_start('init_thru_enddef')
=> oasis_debug_exit (subname)


oasis_get_localcomm (in mod_oasis_method): no global structures
oasis_start_grids_writing (in mod_oasis_grid) (iwrite): global structures
=> oasis_debug_enter(subname)
iwrite = 1   ! just set grids are needed always
=> oasis_debug_exit(subname)

oasis_write_grid (in mod_oasis_grid): (cgrid, nx, ny, lon, lat, partid): global structures
! Warning: nx et ny are the global dimensions of the grid while lon and lat are local arrays
=> oasis_debug_enter(subname)
=> oasis_findgrid(cgrid,nx,ny,gridID)


oasis_write_corner (in mod_oasis_grid): global structures
oasis_write_area (in mod_oasis_grid): global structures
oasis_write_mask (in mod_oasis_grid): global structures
oasis_terminate_grids_writing (in mod_oasis_grid): global structures 
=> oasis_debug_enter(subname)
=> oasis_print_grid_data()
=> oasis_debug_exit(subname)


oasis_def_partition (in mod_oasis_part): (id_part, kparal, kinfo, ig_size,name): global structures 
Allocation of the global structure prism_part (mpart) of type (prism_part_type) !  mpart=100 hard coded in the module
=> oasis_debug_enter(subname)
=> oasis_timer_start('part definition')
prism_npart = prism_npart + 1   ! New part_id if new grid definition
=> oasis_part_zero(prism_part(prism_npart))     ! Initialisation (in particular prism_part%partname = trim(cspval) with cspval="spval_undef")
if (present(name)) then
        if (len_trim(name) > len(prism_part(prism_npart)%partname)) then
           write(nulprt,*) subname,estr,'part name too long = ',trim(name)
           write(nulprt,*) subname,estr,'part name max length = ',len(prism_part(prism_npart)%partname)
           call oasis_abort()
        endif
prism_part(prism_npart)%partname = trim(name)
else
        part_name_cnt = part_name_cnt + 1
write(prism_part(prism_npart)%partname,'(a,i6.6)') trim(compnm)//'_part',part_name_cnt
endif
if (present(ig_size)) then
      prism_part(prism_npart)%ig_size = ig_size
endif
prism_part(prism_npart)%kparal = kparal
=> oasis_timer_stop('part definition')
=> oasis_debug_exit(subname)


oasis_def_var (in mod_oasis_var): (id_nports, cdport, id_part, id_var_nodims, kinout, id_var_shape, ktype, kinfo): global structures
Definition of the number of the variable prism_nvar (= id_nports)
Definition of the global structure prism_var (mvar) of type (prism_var_type)
=> oasis_debug_enter(subname)
if (.not. oasis_coupled) then
     call oasis_debug_exit(subname)
     return
endif
if (.not. l_field_in_namcouple) then           ! This variable mut not be exchanged else there will be an abort in oasis_put/oasis_get
        id_nports = OASIS_Var_Uncpl
        if (OASIS_debug >= 2) then
           write(nulprt,*) subname,' variable not in namcouple return ',trimmed_cdport
           call oasis_flush(nulprt)
        endif
        call oasis_debug_exit(subname)
        return
endif
=> oasis_var_zero(prism_var(prism_nvar))    ! Initialisation
=> oasis_debug_exit(subname)


oasis_enddef (in mod_oasis_method): 
=> oasis_debug_enter(subname)
if (enddef_called) then
       write(nulprt,*) subname,estr,'enddef called already'
       CALL oasis_abort()
endif
enddef_called = .true.
if (.not. oasis_coupled) then
      call oasis_debug_exit(subname)
      return
endif
icpl = MPI_UNDEFINED
if (mpi_comm_local /= MPI_COMM_NULL) icpl = 1
=> MPI_COMM_Split(mpi_comm_global,icpl,1,newcomm,ierr)
mpi_comm_global = newcomm
if (mpi_comm_global /= MPI_COMM_NULL) then
=> MPI_Comm_Size(mpi_comm_global,mpi_size_global,ierr)
=> MPI_Comm_Rank(mpi_comm_global,mpi_rank_global,ierr)
=> mod_oasis_setrootglobal()
=> oasis_part_setup()   ! Definition of the global structure prism_part (mpart) of type (prism_part_type)
=> oasis_var_setup()     ! Definition of the global structure prism_var (mvar) of type (prism_var_type) over the tasks
=> oasis_mpi_barrier (mpi_comm_global)
=> oasis_write2files ! To write files grids.nc, masks.nc and areas.nc
=> oasis_mpi_barrier (mpi_comm_global)
=> mct_world_init (prism_nmodels,mpi_comm_global,mpi_comm_local,compid)
=> oasis_coupler_setup () ! definition of global variables prism_mapper (type prism_mapper_type), prism_coupler (type prism_coupler_type)
=> oasis_debug_enter(subname)
=> oasis_timer_start('cpl_setup')
=> oasis_debug_note(subname//' set defaults for datatypes')
prism_coupler(nc)%aVon(:) = .false.
=> oasis_debug_note(subname//' share var info between models')
=> oasis_mpi_bcast(mynvar,mpi_comm_global,'mynvar',model_root(n))
=> oasis_mpi_bcast(myvar,mpi_comm_global,'myvar',model_root(n))
=> oasis_mpi_bcast(myops,mpi_comm_global,'myops',model_root(n))
=> oasis_debug_note(subname//' compare vars and namcouple')
=> oasis_debug_note(subname//' setup couplers')
=> oasis_mpi_barrier(mpi_comm_global)
=> oasis_debug_note(subname//' initialize coupling datatypes')
initialize avect1
=> mct_avect_init(prism_coupler(nc)%avect1,rList=trim(prism_coupler(nc)%fldlist),lsize=lsize)
=> mct_avect_zero(prism_coupler(nc)%avect1)
prism_coupler(nc)%aVon(1) = .true.
Mapping file :
if (prism_mapper(mapID)%init) then   ! mapper already initialized
else  ! read/generate mapping file
inquire(file=trim(prism_mapper(mapID)%file),exist=exists)
if (.not.exists) then   ! Create the file with SCRIP : the files areas.nc, grids.nc and masks.nc must be accessible
=> oasis_coupler_genmap(mapID,namID)
=> oasis_io_read_field_from_root : read the files areas.nc, grids.nc and masks.nc
=> grid_init
=> scrip        ! defined in oasis3-mct/lib/scrip/src
endif
=> oasis_mpi_bcast(gsize,mpi_comm_local,subname//' gsize')
=> oasis_part_create(part2,'1d',gsize,nx,ny,gridname)
=> oasis_timer_start('cpl_smatrd')
!-------------------------------
! smatreaddnc allocates sMati to nwgts
! then instantiate an sMatP for each set of wgts
! to support higher order mapping
!-------------------------------
=> oasis_coupler_smatreaddnc (sMati,prism_part(spart)%gsmap,prism_part(dpart)%gsmap,&  
                                                        trim(cstring),trim(prism_mapper(mapID)%file),mpi_rank_local,mpi_comm_local, nwgts)
=> mct_sMatP_Init(prism_mapper(mapID)%sMatP(n), sMati(n), prism_part(spart)%gsmap, prism_part(dpart)%gsmap, 0, mpi_comm_local, compid)
=> mct_sMat_Clean(sMati(n))
=> oasis_timer_stop('cpl_smatrd')
endif  ! generation of remapping file
if (.not.prism_mapper(mapID)%AVred .and. prism_coupler(nc)%conserv /= ip_cnone) then
=> mct_avect_init(prism_mapper(mapID)%av_ms,iList='mask',rList='area',lsize=lsize)
        => mct_avect_zero(prism_mapper(mapID)%av_ms)
=> oasis_io_read_avfld('masks.nc',prism_mapper(mapID)%av_ms, prism_part(spart)%gsmap,'mask',trim(gridname)//'.msk',fldtype='int')
=> oasis_io_read_avfld('areas.nc',prism_mapper(mapID)%av_ms, prism_part(spart)%gsmap,'area',trim(gridname)//'.srf',fldtype='real')
=> mct_avect_init(prism_mapper(mapID)%av_md,iList='mask',rList='area',lsize=lsize)
=> mct_avect_zero(prism_mapper(mapID)%av_md)
=> oasis_io_read_avfld('masks.nc',prism_mapper(mapID)%av_md, prism_part(dpart)%gsmap,'mask',trim(gridname)//'.msk',fldtype='int')
=> oasis_io_read_avfld('areas.nc',prism_mapper(mapID)%av_md, prism_part(dpart)%gsmap,'area',trim(gridname)//'.srf',fldtype='real')
endif
initialize avect1m
=> mct_avect_init(prism_coupler(nc)%avect1m,rList=trim(prism_coupler(nc)%fldlist),lsize=lsize)
=> mct_avect_zero(prism_coupler(nc)%avect1m)
if (prism_coupler(nc)%sndrcv) then
=> mct_router_init(prism_coupler(nc)%comp,prism_part(rpart)%gsmap, mpi_comm_local,prism_router(prism_coupler(nc)%routerID)%router)
endif
=> oasis_coupler_print(nc)
=> oasis_timer_stop('cpl_setup')
=> oasis_debug_exit(subname)
=> oasis_advance_init (lkinfo) : read the restart fields and the loctrans fields if necessary
=> oasis_debug_enter(subname)
=> oasis_timer_start ('advance_init')
=> oasis_debug_note(subname//' loop over cplid')
Loop cplid = 1,prism_ncoupler
if (getput == PRISM_PUT .and. lag > 0) then  (reading of the restart file)
=> oasis_debug_note(subname//' check for lag restart')
=> mct_aVect_init (avtmp,rlist=prism_coupler(cplid)%fldlist,lsize=lsize)
=> oasis_io_read_avfile(trim(rstfile),avtmp,prism_part(partid)%gsmap)
=> mct_aVect_init(avtmp2,rlist=prism_coupler(cplid)%fldlist,lsize=lsize)
=> oasis_io_read_avfile(trim(rstfile),avtmp2,prism_part(partid)%gsmap, abort=.false.,nampre='av2_',didread=a2on)
...
=> mct_aVect_init(avtmp5,rlist=prism_coupler(cplid)%fldlist,lsize=lsize)
=> oasis_io_read_avfile(trim(rstfile),avtmp5,prism_part(partid)%gsmap, abort=.false.,nampre='av5_',didread=a5on)
=> oasis_advance_run(OASIS_Out,varid,msec,array,kinfo,readrest=.true., &
               a2on=a2on,array2=array2,a3on=a3on,array3=array3, &
               a4on=a4on,array4=array4,a5on=a5on,array5=array5)        !!! see description below in oasis_put/get
array2 allocated and given a value only if a2on=.true. , etc ...
=> mct_avect_clean(avtmp) + deallocation array
=> if a2on=.true. then mct_avect_clean(avtmp2) + deallocation array2
...
=> if a5on=.true. then mct_avect_clean(avtmp5) + deallocation array5
endif
if (getput == PRISM_PUT .and. prism_coupler(cplid)%trans /= ip_instant) then  (reading of the restart LOCTRANS file)
=> oasis_debug_note(subname//' check for loctrans restart')
=> oasis_io_read_array(rstfile,iarray=prism_coupler(cplid)%avcnt, ivarname=trim(vstring),abort=.false.) ! read the number of counts
=> oasis_io_read_avfile(rstfile,prism_coupler(cplid)%avect1, prism_part(partid)%gsmap,abort=.false.,nampre=trim(vstring)) ! read the loctrans restart
=> mct_aVect_init(prism_coupler(cplid)%aVect2,prism_coupler(cplid)%aVect1,lsize)
=> mct_aVect_zero(prism_coupler(cplid)%aVect2)
=> oasis_io_read_avfile(rstfile,prism_coupler(cplid)%avect2,prism_part(partid)%gsmap,abort=.false.,nampre=trim(vstring),&
                                          didread=prism_coupler(cplid)%aVon(2))
if (.not. prism_coupler(cplid)%aVon(2)) then  call mct_aVect_clean(prism_coupler(cplid)%avect2)
...
=> mct_aVect_init(prism_coupler(cplid)%aVect5,prism_coupler(cplid)%aVect1,lsize)
=> mct_aVect_zero(prism_coupler(cplid)%aVect5)
=> oasis_io_read_avfile(rstfile,prism_coupler(cplid)%avect5,prism_part(partid)%gsmap,abort=.false.,nampre=trim(vstring),&
                                          didread=prism_coupler(cplid)%aVon(5))
if (.not. prism_coupler(cplid)%aVon(5)) then  call mct_aVect_clean(prism_coupler(cplid)%avect5)
endif
end Loop
=> oasis_timer_stop ('advance_init')
=> oasis_debug_exit(subname)
=> oasis_debug_exit(subname)

oasis_put:  == oasis_put (id_port_id,kstep,wr_field,kinfo)
=> prism_advance_run (PRISM_Out,nfld,kstep,array,kinfo)
if (getput == PRISM_PUT .and. lag > 0) then
=> prism_timer_start (tstring)
=> prism_io_write_avfile(rstfile,prism_coupler(cplid)%avect1,prism_part(partid)%gsmap,nx,ny)
=> prism_timer_stop (tstring)
endif
if (sndrcv) then
if (getput == PRISM_PUT) then
if (snddiag) then
=> prism_advance_avdiag(prism_coupler(cplid)%avect1,mpi_comm_local)
endif
if (mapid > 0) then
=> prism_timer_start(tstring)
=> mct_avect_zero(prism_coupler(cplid)%avect2)
=> prism_advance_map(prism_coupler(cplid)%avect1,prism_coupler(cplid)%avect2,prism_mapper(mapid),conserv)
=> prism_timer_stop(tstring)
=> prism_timer_start(tstring)
=> mct_waitsend(prism_router(rouid)%router)
=> mct_isend(prism_coupler(cplid)%avect2,prism_router(rouid)%router,tag)
=> prism_timer_stop(tstring)
else !mapid
=> prism_timer_start(tstring)
=> mct_waitsend(prism_router(rouid)%router)
=> mct_isend(prism_coupler(cplid)%avect1,prism_router(rouid)%router,tag)
=> prism_timer_stop(tstring)
endif
endif
endif
if (output) then
=> prism_timer_start(tstring)
=> prism_io_write_avfbf(prism_coupler(cplid)%avect1,prism_part(partid)%gsmap,nx,ny,msec,fstring)
=> prism_timer_stop(tstring)
endif

oasis_get: == oasis_get (id_port_id,kstep,rd_field,kinfo)
=> prism_advance_run (PRISM_In,nfld,kstep,array,kinfo)

oasis_terminate (in mod_oasis_method): 
=> oasis_debug_enter(subname)
if (.not. oasis_coupled) then
      call oasis_debug_exit(subname)
      return
endif
=> oasis_timer_stop ('total')
=> oasis_timer_print
IF ( .NOT. lg_mpiflag ) THEN
       IF (OASIS_debug >= 2)  THEN
           WRITE (nulprt,FMT='(A)') subname//': Calling MPI_Finalize'
           CALL oasis_flush(nulprt)
       ENDIF
       CALL MPI_Finalize ( ierr )
else
       IF (OASIS_debug >= 2)  THEN
           WRITE (nulprt,FMT='(A)') subname//': Not Calling MPI_Finalize'
           CALL oasis_flush(nulprt)
       ENDIF
ENDIF
=> oasis_mem_print(nulprt,subname)
IF (mpi_rank_local == 0)  THEN
       WRITE(nulprt,*) subname,' SUCCESSFUL RUN'
       CALL oasis_flush(nulprt)
ENDIF
=> oasis_debug_exit(subname)