!-------------------------------------- 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 v4d_rwfld - Read (Write) a specific field (HEART only) from (on) WA file
*
#include "model_macros_f.h"
*
subroutine v4d_rwfld (F_field,F_work,Ni,Nj,DIST_DIM,Nk, 318,7
% F_iun,F_addr,F_diag_L,F_name_S,F_adjoint_L,F_diff,F_icode)
*
implicit none
*
integer Ni,Nj,DIST_DIM,Nk,F_icode
real F_field(DIST_SHAPE,Nk),F_work(*)
*
integer F_iun,F_addr,F_diff
logical F_diag_L,F_adjoint_L
character*8 F_name_S
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_31 - Tanguay M. - change parameters of v4d_rwfld
* - WA files incore
* v3_00 - Tanguay M - incore option for Conversion WA file
* v3_00 - Laroche S. - adapted for simplified physics
* v3_02 - Buehner M. - added section for ref state file for NLMX event (SV job)
* v3_11 - Tanguay M. - Diagnostics
* v3_21 - Tanguay M. - Revision Openmp
* v3_30 - Tanguay M. - Validation for LAM version
*
*object
* see id section
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_field I/O Field with HALO
* F_work w Field without HALO
* Ni Nj I Horizontal dim. of F_work
* DIST_DIM I Horizontal dim. of F_field
* Nk I Vertical dim. of F_work,F
* F_iun I Unit of WA file
* F_addr I/O Position in WA file
* F_diag_L I Give diagnostics if TRUE
* F_name_S I Name of the field
* F_adjoint_L I TRUE if adjoint run
* F_diff I To be subtracted from position if adjoint run
* F_icode I If F_icode.GT.0 -Transfer F_field (HEART only) in F_work
* -Write F_work in WA file
* If F_icode.LE.0 -Read F_work from WA file
* -Transfer F_work in F_field (HEART only)
*----------------------------------------------------------------
*
*implicits
#include "lun.cdk"
#include "v4dg.cdk"
*
integer i,j,k,ind
*
if (F_icode.gt.0) then
*
if(.not.V4dg_incore_L) then
*
* Transfer F_field (HEART only) in F_work
* ---------------------------------------
!$omp parallel do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_work(ind) = F_field(i,j,k)
end do
end do
end do
!$omp end parallel do
*
endif
*
* Write F_work on WA file or incore
* ---------------------------------
if(V4dg_incore_L) then
*
if(F_iun.eq.V4dg_iuntr) then
*
if(V4dg_trsize.lt.F_addr + Ni*Nj*Nk - 1) then
call gem_stop ('v4d_rwfld ARRAY TRINCORE TOO SMALL',-1)
endif
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
V4dg_trincore(F_addr + ind - 1) = F_field(i,j,k)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunph) then
*
if(V4dg_phsize.lt.F_addr + Ni*Nj*Nk - 1) then
call gem_stop ('v4d_rwfld ARRAY PHINCORE TOO SMALL',-1)
endif
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
V4dg_phincore(F_addr + ind - 1) = F_field(i,j,k)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunfr) then
*
if(V4dg_frsize.lt.F_addr + Ni*Nj*Nk - 1) then
call gem_stop ('v4d_rwfld ARRAY FRINCORE TOO SMALL',-1)
endif
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
V4dg_frincore(F_addr + ind - 1) = F_field(i,j,k)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunob) then
*
if(V4dg_obsize.lt.F_addr + Ni*Nj*Nk -1) then
call gem_stop ('v4d_rwfld ARRAY OBINCORE TOO SMALL',-1)
endif
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
V4dg_obincore(F_addr + ind - 1) = F_field(i,j,k)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iuncv) then
*
if(V4dg_cvsize.lt.F_addr + Ni*Nj*Nk - 1) then
call gem_stop ('v4d_rwfld ARRAY CVINCORE TOO SMALL',-1)
endif
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
V4dg_cvincore(F_addr + ind - 1) = F_field(i,j,k)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunnl) then
*
if(V4dg_nlsize.lt.F_addr + Ni*Nj*Nk - 1) then
call gem_stop ('v4d_rwfld ARRAY NLINCORE TOO SMALL',-1)
endif
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
V4dg_nlincore(F_addr + ind - 1) = F_field(i,j,k)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunns) then
*
if(V4dg_nssize.lt.F_addr + Ni*Nj*Nk - 1) then
call gem_stop ('v4d_rwfld ARRAY NSINCORE TOO SMALL',-1)
endif
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
V4dg_nsincore(F_addr + ind - 1) = F_field(i,j,k)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
endif
*
else
*
call wawrit (F_iun,F_work,F_addr,Ni*Nj*Nk)
*
endif
*
* Diagnostics
* -----------
if(F_diag_L) write(Lun_out,*)
% 'WA FILE: wawrit ','Waf_adr = ',F_addr,'for ',F_name_S
*
* Update address
* --------------
F_addr = F_addr + Ni*Nj*Nk
*
else
*
* Read F_work from WA file or incore
* ----------------------------------
if(V4dg_incore_L) then
*
if(F_iun.eq.V4dg_iuntr) then
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_field(i,j,k) = V4dg_trincore(F_addr + ind - 1)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunph) then
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_field(i,j,k) = V4dg_phincore(F_addr + ind - 1)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunfr) then
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_field(i,j,k) = V4dg_frincore(F_addr + ind - 1)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunob) then
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_field(i,j,k) = V4dg_obincore(F_addr + ind - 1)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iuncv) then
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_field(i,j,k) = V4dg_cvincore(F_addr + ind - 1)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunnl) then
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_field(i,j,k) = V4dg_nlincore(F_addr + ind - 1)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
elseif(F_iun.eq.V4dg_iunns) then
*
!$omp parallel private(ind)
!$omp do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_field(i,j,k) = V4dg_nsincore(F_addr + ind - 1)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
endif
*
else
*
call waread (F_iun,F_work,F_addr,Ni*Nj*Nk)
*
endif
*
* Transfer F_work in F_field (HEART only)
* ---------------------------------------
*
if(.not.V4dg_incore_L) then
*
!$omp parallel do
do k=1,Nk
do j=1,Nj
do i=1,Ni
ind = Ni*Nj*(k-1) + Ni*(j-1)+i
F_field(i,j,k) = F_work(ind)
end do
end do
end do
!$omp end parallel do
*
endif
*
* Diagnostics
* -----------
if(F_diag_L) write(Lun_out,*)
% 'WA FILE: waread ','Waf_adr = ',F_addr,'for ',F_name_S
*
* Update address
* --------------
if( F_adjoint_L) F_addr = F_addr - F_diff
if(.not.F_adjoint_L) F_addr = F_addr + Ni*Nj*Nk
*
endif
*
* ---------------------------------------------------------------
*
return
end