!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***s/r wr1rstrt - Write one binary restart file for all tiles
*
#include "model_macros_f.h"
*
subroutine wr1rstrt () 1,5
*
implicit none
*
*author
* K. Winger - November 2006
*
*revision
* v3_30 - Desgagne, Winger & Dugas - initial version
* v3_31 - Desgagne M. - new coupling interface to OASIS
*
*object
*
*arguments
* none
*
*implicits
#include "lun.cdk"
#include "init.cdk"
#include "rstr.cdk"
#include "lctl.cdk"
#include "schm.cdk"
#include "itf_phy_buses.cdk"
#include "itf_cpl.cdk"
#include "glb_ld.cdk"
#include "pres.cdk"
#include "lam.cdk"
#include "itf_chm_bus.cdk"
#include "ptopo.cdk"
#include "bcsmem.cdk"
*
*modules
integer fnom,fclos
external fnom,fclos
*
integer r, j, err, current_nest, dim_cpl
integer prows, crows, pos_3D, pos_cube, ni, nj
*
real, dimension (:), allocatable :: Phy_busper_cube
real, dimension (:), allocatable :: Phy_busper_cube_digf
real, dimension (:), allocatable :: Phy_busper_glb
real, dimension (:), allocatable :: Phy_busper_glb_digf
*
real, dimension (:), allocatable :: Cpl_rga_cpl2phy
real, dimension (:), allocatable :: Cpl_rla_msk
*
real, dimension (:), allocatable :: Chm_busper_cube
real, dimension (:), allocatable :: Chm_busper_glb
*
CCC real, dimension (:), allocatable :: BCS_glb
*
* ---------------------------------------------------------------
*
if (G_lam) then
if (Lun_out.gt.0) write(6,1000)
call gem_stop("wr1rstrt",-111)
*
ni = G_ni - pil_e - pil_w + 6
nj = G_nj - pil_n - pil_s + 6
else
ni = G_ni
nj = G_nj
endif
*
crows = 0
prows = 0
*
C Regroup variables in Phy_busper3D from slabs to cubes per variable
*
if (Schm_phyms_L) then
*
allocate ( Phy_busper_cube (p_bper_siz*p_nj ) )
*
prows = p_bper_siz / p_ni
pos_cube = 1
do r=1,prows
do j=1,p_nj
pos_3D = (j-1)*p_bper_siz + (r-1)*p_ni + 1
Phy_busper_cube (pos_cube:pos_cube+p_ni-1) =
& Phy_busper3D (pos_3D :pos_3D +p_ni-1)
pos_cube = pos_cube + p_ni
enddo
enddo
*
C Collect cubes from all processors
*
if (Ptopo_myproc.eq.0) allocate (Phy_busper_glb(prows*ni*nj))
call glbcolc (Phy_busper_glb,ni,nj,
& Phy_busper_cube,1,p_ni,1,p_nj,prows)
*
deallocate ( Phy_busper_cube )
*
end if
*
C Regroup variables in Phy_busper3D_digf from slabs to cubes per variable
*
if ( Schm_phyms_L .and. Init_balgm_L .and.
& Rstri_half_L .and. .not.Rstri_idon_L) then
*
allocate (Phy_busper_cube_digf(p_bper_siz*p_nj))
*
pos_cube = 1
do r=1,prows
do j=1,p_nj
pos_3D = (j-1)*p_bper_siz + (r-1)*p_ni + 1
Phy_busper_cube_digf (pos_cube:pos_cube+p_ni-1) =
& Phy_busper3D_digf (pos_3D :pos_3D +p_ni-1)
pos_cube = pos_cube + p_ni
enddo
enddo
*
C Collect cubes from all processors
*
if (Ptopo_myproc.eq.0)
& allocate ( Phy_busper_glb_digf (prows*ni*nj) )
call glbcolc (Phy_busper_glb_digf,ni,nj,
& Phy_busper_cube_digf,1,p_ni,1,p_nj,prows)
*
deallocate ( Phy_busper_cube_digf )
*
end if
*
if (Ptopo_myproc.eq.0) then
*
Lun_rstrt = 0
err = fnom (Lun_rstrt,'../restart_glbphy.bin','SEQ/UNF',0)
write (Lun_rstrt) Lctl_step
write (Lun_rstrt) Rstri_idon_L
*
C Write global physic cube(s)
*
if (Schm_phyms_L) then
*
C Write variables for later check
*
write (Lun_rstrt) prows, ni, nj, p_bper_top
write (Lun_rstrt) pernm (1:p_bper_top)
write (Lun_rstrt) perpar(1:p_bper_top,1)/p_ni
*
write (Lun_rstrt) Phy_busper_glb
deallocate ( Phy_busper_glb )
write (Lun_rstrt) Rstri_half_L
*
if ( Init_balgm_L .and.
& .not.Rstri_idon_L .and.
& Rstri_half_L ) then
write (Lun_rstrt) Phy_busper_glb_digf
deallocate ( Phy_busper_glb_digf )
endif
*
else
write (Lun_rstrt) prows
endif
*
write (Lun_rstrt) pres_surf
write (Lun_rstrt) pres_top
call datp2f (current_nest,Lam_current_S )
write (Lun_rstrt) current_nest
*
err = fclos(Lun_rstrt)
*
endif
*
C Regroup variables in Chm_busper3D from slabs to cubes per variable
*
if (Schm_chems_L) then
*
allocate ( Chm_busper_cube (chm_bper_siz*chm_nj ) )
*
crows = chm_bper_siz / chm_ni
pos_cube = 1
do r=1,crows
do j=1,chm_nj
pos_3D = (j-1)*chm_bper_siz + (r-1)*chm_ni + 1
Chm_busper_cube (pos_cube:pos_cube+chm_ni-1) =
& Chm_busper3D (pos_3D :pos_3D +chm_ni-1)
pos_cube = pos_cube + chm_ni
enddo
enddo
*
C Collect cubes from all processors
*
if (Ptopo_myproc.eq.0) allocate (Chm_busper_glb(crows*ni*nj))
call glbcolc (Chm_busper_glb,ni,nj,
& Chm_busper_cube,1,chm_ni,1,chm_nj,crows)
*
deallocate ( Chm_busper_cube )
*
C Write global chemistry cube
*
if (Ptopo_myproc.eq.0) then
*
Lun_rstrt = 0
err = fnom (Lun_rstrt,'../restart_glbchm.bin','SEQ/UNF',0)
write (Lun_rstrt) Lctl_step
*
C Write variables for later check
write (Lun_rstrt) crows, ni, nj, chm_bper_top
write (Lun_rstrt) chmpernm (1:chm_bper_top)
write (Lun_rstrt) chmperpar(1:chm_bper_top,1)/chm_ni
*
write (Lun_rstrt) Chm_busper_glb
deallocate ( Chm_busper_glb )
*
err = fclos(Lun_rstrt)
*
endif
*
endif
*
* ---------------------------------------------------------------
*
1000 format(/' LAM MODE NOT SUPPORTED BY WR1RSTRT...'/)
*
return
end