C $Header: /u/gcmpack/MITgcm/pkg/ctrl/ctrl_map_ini_genarr.F,v 1.28 2017/09/18 15:16:52 gforget Exp $
C $Name: $
#include "CTRL_OPTIONS.h"
#ifdef ALLOW_GMREDI
# include "GMREDI_OPTIONS.h"
#endif
CBOP
C !ROUTINE: CTRL_MAP_INI_GENARR
C !INTERFACE:
SUBROUTINE CTRL_MAP_INI_GENARR( myThid )
C !DESCRIPTION: \bv
C *=================================================================
C | SUBROUTINE CTRL_MAP_INI_GENARR
C | Add the generic arrays of the
C | control vector to the model state and update the tile halos.
C | The control vector is defined in the header file "ctrl.h".
C *=================================================================
C \ev
C !USES:
IMPLICIT NONE
C == global variables ==
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "GRID.h"
#include "DYNVARS.h"
#include "FFIELDS.h"
#include "CTRL_SIZE.h"
#include "ctrl.h"
#include "optim.h"
#include "ctrl_dummy.h"
#include "CTRL_FIELDS.h"
#include "CTRL_GENARR.h"
#ifdef ALLOW_PTRACERS
# include "PTRACERS_SIZE.h"
# include "PTRACERS_FIELDS.h"
#endif
C !INPUT/OUTPUT PARAMETERS:
C == routine arguments ==
INTEGER myThid
C !LOCAL VARIABLES:
C == local variables ==
#if (defined (ALLOW_GENARR2D_CONTROL) defined(ALLOW_GENARR3D_CONTROL))
integer iarr
#endif
#ifdef ALLOW_GENARR2D_CONTROL
integer igen_etan,igen_bdrag,igen_geoth
#endif /* ALLOW_GENARR2D_CONTROL */
#ifdef ALLOW_GENARR3D_CONTROL
integer igen_theta0, igen_salt0
integer igen_kapgm, igen_kapredi, igen_diffkr
#if (defined (ALLOW_UVEL0_CONTROL) defined (ALLOW_VVEL0_CONTROL))
integer igen_uvel0, igen_vvel0
#endif
#endif /* ALLOW_GENARR3D_CONTROL */
CEOP
#ifdef ALLOW_GENARR2D_CONTROL
C-- generic 2D control variables
igen_etan=0
igen_bdrag=0
igen_geoth=0
DO iarr = 1, maxCtrlArr2D
if (xx_genarr2d_weight(iarr).NE.' ') then
if (xx_genarr2d_file(iarr)(1:7).EQ.'xx_etan')
& igen_etan=iarr
if (xx_genarr2d_file(iarr)(1:13).EQ.'xx_bottomdrag')
& igen_bdrag=iarr
if (xx_genarr2d_file(iarr)(1:13).EQ.'xx_geothermal')
& igen_geoth=iarr
endif
ENDDO
if (igen_etan.GT.0) then
call CTRL_MAP_GENARR2D(etaN,igen_etan,myThid)
endif
#ifdef ALLOW_BOTTOMDRAG_CONTROL
if (igen_bdrag.GT.0)
& call CTRL_MAP_GENARR2D(bottomDragFld,igen_bdrag,myThid)
#endif
#ifdef ALLOW_GEOTHERMAL_FLUX
if (igen_geoth.GT.0)
& call CTRL_MAP_GENARR2D(geothermalFlux,igen_geoth,myThid)
#endif
#endif /* ALLOW_GENARR2D_CONTROL */
#ifdef ALLOW_GENARR3D_CONTROL
C-- generic 3D control variables
igen_theta0=0
igen_salt0=0
igen_kapgm=0
igen_kapredi=0
igen_diffkr=0
DO iarr = 1, maxCtrlArr3D
if (xx_genarr3d_weight(iarr).NE.' ') then
if (xx_genarr3d_file(iarr)(1:8).EQ.'xx_theta')
& igen_theta0=iarr
if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_salt')
& igen_salt0=iarr
if (xx_genarr3d_file(iarr)(1:8).EQ.'xx_kapgm')
& igen_kapgm=iarr
if (xx_genarr3d_file(iarr)(1:10).EQ.'xx_kapredi')
& igen_kapredi=iarr
if (xx_genarr3d_file(iarr)(1:9).EQ.'xx_diffkr')
& igen_diffkr=iarr
#if (defined (ALLOW_UVEL0_CONTROL) defined (ALLOW_VVEL0_CONTROL))
if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_uvel')
& igen_uvel0=iarr
if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_vvel')
& igen_vvel0=iarr
#endif
endif
ENDDO
if (igen_theta0.GT.0)
& call CTRL_MAP_GENARR3D(theta,igen_theta0,myThid)
if (igen_salt0.GT.0)
& call CTRL_MAP_GENARR3D(salt,igen_salt0,myThid)
#ifdef ALLOW_KAPGM_CONTROL
if (igen_kapgm.GT.0)
& call CTRL_MAP_GENARR3D(kapgm,igen_kapgm,myThid)
#endif
#ifdef ALLOW_KAPREDI_CONTROL
if (igen_kapredi.GT.0)
& call CTRL_MAP_GENARR3D(kapredi,igen_kapredi,myThid)
#endif
#ifdef ALLOW_3D_DIFFKR
if (igen_diffkr.GT.0)
& call CTRL_MAP_GENARR3D(diffkr,igen_diffkr,myThid)
#endif
#if (defined (ALLOW_UVEL0_CONTROL) defined (ALLOW_VVEL0_CONTROL))
if (igen_uvel0.GT.0 .and. igen_vvel0.GT.0) then
call CTRL_MAP_GENARR3D(uvel,igen_uvel0,myThid)
call CTRL_MAP_GENARR3D(vvel,igen_vvel0,myThid)
CALL EXCH_UV_XYZ_RL(uvel,vvel,.TRUE.,myThid)
endif
#endif
#endif /* ALLOW_GENARR3D_CONTROL */
RETURN
END
C---------------------------
C !ROUTINE: CTRL_MAP_GENARR2D
C !INTERFACE:
SUBROUTINE CTRL_MAP_GENARR2D( fld, iarr, myThid )
C !DESCRIPTION: \bv
C *=================================================================
C | SUBROUTINE CTRL_MAP_GENARR2D
C | Add the generic arrays of the
C | control vector to the model state and update the tile halos.
C | The control vector is defined in the header file "ctrl.h".
C *=================================================================
C \ev
C !USES:
IMPLICIT NONE
C == global variables ==
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "GRID.h"
#include "CTRL_SIZE.h"
#include "ctrl.h"
#include "optim.h"
#include "CTRL_GENARR.h"
#include "ctrl_dummy.h"
C !INPUT/OUTPUT PARAMETERS:
C == routine arguments ==
_RL fld (1-olx:snx+olx,1-oly:sny+oly,nsx,nsy)
INTEGER iarr
INTEGER myThid
#ifdef ALLOW_GENARR2D_CONTROL
C !LOCAL VARIABLES:
C == local variables ==
integer bi,bj
integer i,j
integer jmin,jmax
integer imin,imax
integer numsmo, k2
logical dowc01
logical dosmooth
logical doscaling
_RL xx_gen (1-olx:snx+olx,1-oly:sny+oly,nsx,nsy)
_RS dummyRS(1)
character*(80) fnamegenIn
character*(80) fnamegenOut
character*(80) fnamebase
INTEGER ILNBLNK
EXTERNAL
integer ilgen
logical doglobalread
logical ladinit
CEOP
c-- Now, read the control vector.
doglobalread = .false.
ladinit = .false.
DO bj=myByLo(myThid), myByHi(myThid)
DO bi=myBxLo(myThid), myBxHi(myThid)
DO j = 1-OLy,sNy+OLy
DO i = 1-OLx,sNx+OLx
xx_gen(i,j,bi,bj)=0. _d 0
ENDDO
ENDDO
ENDDO
ENDDO
dosmooth=.false.
dowc01 = .false.
doscaling=.true.
numsmo=1
do k2 = 1, maxCtrlProc
if (xx_genarr2d_preproc(k2,iarr).EQ.'WC01') then
dowc01=.TRUE.
if (xx_genarr2d_preproc_i(k2,iarr).NE.0)
& numsmo=xx_genarr2d_preproc_i(k2,iarr)
endif
if ((.NOT.dowc01).AND.
& (xx_genarr2d_preproc(k2,iarr).EQ.'smooth')) then
dosmooth=.TRUE.
if (xx_genarr2d_preproc_i(k2,iarr).NE.0)
& numsmo=xx_genarr2d_preproc_i(k2,iarr)
endif
if (xx_genarr2d_preproc(k2,iarr).EQ.'noscaling') then
doscaling=.FALSE.
endif
enddo
fnamebase = xx_genarr2d_file(iarr)
ilgen=ilnblnk( fnamebase )
write(fnamegenIn(1:80),'(2a,i10.10)')
& fnamebase(1:ilgen),'.',optimcycle
write(fnamegenOut(1:80),'(2a,i10.10)')
& fnamebase(1:ilgen),'.effective.',optimcycle
CALL MDS_READ_FIELD(xx_genarr2d_weight(iarr),ctrlprec,.FALSE.,
& 'RL',1,1,1,wgenarr2d(1-Olx,1-Oly,1,1,iarr),dummyRS,1,mythid)
#ifdef ALLOW_AUTODIFF
call ACTIVE_READ_XY( fnamegenIn, xx_gen, 1, doglobalread,
& ladinit, optimcycle, mythid, xx_genarr2d_dummy(iarr) )
#else
CALL READ_REC_XY_RL( fnamegenIn, xx_gen, 1, 1, myThid)
#endif
#ifdef ALLOW_SMOOTH
IF (useSMOOTH) THEN
IF (dowc01) call SMOOTH_CORREL2D(xx_gen,maskC,numsmo,mythid)
IF (dosmooth) call SMOOTH2D(xx_gen,maskC,numsmo,mythid)
ENDIF
#endif
DO bj=myByLo(myThid), myByHi(myThid)
DO bi=myBxLo(myThid), myBxHi(myThid)
DO j = 1,sNy
DO i = 1,sNx
c scale param adjustment
IF (doscaling) then
if ( (maskC(i,j,1,bi,bj).NE.0.).AND.
& (wgenarr2d(i,j,bi,bj,iarr).GT.0.) ) then
xx_gen(i,j,bi,bj)=xx_gen(i,j,bi,bj)
& /sqrt( wgenarr2d(i,j,bi,bj,iarr) )
else
xx_gen(i,j,bi,bj)=0.
endif
ENDIF
c add to model parameter
fld(i,j,bi,bj)=fld(i,j,bi,bj)+xx_gen(i,j,bi,bj)
enddo
enddo
enddo
enddo
c avoid param out of [boundsVec(1) boundsVec(4)]
CALL CTRL_BOUND_2D(fld,maskC,xx_genarr2d_bounds(1,iarr),myThid)
CALL EXCH_XY_RL( fld, mythid )
CALL MDS_WRITE_FIELD(fnamegenOut,ctrlprec,.FALSE.,.FALSE.,
& 'RL',1,1,1,fld,dummyRS,1,optimcycle,mythid)
#endif /* ALLOW_GENARR2D_CONTROL */
RETURN
END
C---------------------------
C !ROUTINE: CTRL_MAP_GENARR3D
C !INTERFACE:
SUBROUTINE CTRL_MAP_GENARR3D( fld, iarr, myThid )
C !DESCRIPTION: \bv
C *=================================================================
C | SUBROUTINE CTRL_MAP_GENARR3D
C | Add the generic arrays of the
C | control vector to the model state and update the tile halos.
C | The control vector is defined in the header file "ctrl.h".
C *=================================================================
C \ev
C !USES:
IMPLICIT NONE
C == global variables ==
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "GRID.h"
#include "CTRL_SIZE.h"
#include "ctrl.h"
#include "optim.h"
#include "CTRL_GENARR.h"
#include "ctrl_dummy.h"
C !INPUT/OUTPUT PARAMETERS:
C == routine arguments ==
_RL fld (1-olx:snx+olx,1-oly:sny+oly,nr,nsx,nsy)
INTEGER iarr
INTEGER myThid
#ifdef ALLOW_GENARR3D_CONTROL
C !LOCAL VARIABLES:
C == local variables ==
integer bi,bj
integer i,j,k
integer numsmo,k2
logical dowc01
logical dosmooth
logical doscaling
_RL xx_gen (1-olx:snx+olx,1-oly:sny+oly,nr,nsx,nsy)
_RS dummyRS(1)
character*(80) fnamegenIn
character*(80) fnamegenOut
character*(80) fnamebase
INTEGER ILNBLNK
EXTERNAL
integer ilgen
logical doglobalread
logical ladinit
#if (defined (ALLOW_UVEL0_CONTROL) defined (ALLOW_VVEL0_CONTROL))
_RL localmask (1-olx:snx+olx,1-oly:sny+oly,nr,nsx,nsy)
#endif
CEOP
c-- Now, read the control vector.
doglobalread = .false.
ladinit = .false.
DO bj=myByLo(myThid), myByHi(myThid)
DO bi=myBxLo(myThid), myBxHi(myThid)
DO k = 1,nr
DO j = 1-OLy,sNy+OLy
DO i = 1-OLx,sNx+OLx
xx_gen(i,j,k,bi,bj)=0. _d 0
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
dosmooth=.false.
dowc01 = .false.
doscaling=.true.
numsmo=1
do k2 = 1, maxCtrlProc
if (xx_genarr3d_preproc(k2,iarr).EQ.'WC01') then
dowc01=.TRUE.
if (xx_genarr3d_preproc_i(k2,iarr).NE.0)
& numsmo=xx_genarr3d_preproc_i(k2,iarr)
endif
if ((.NOT.dowc01).AND.
& (xx_genarr3d_preproc(k2,iarr).EQ.'smooth')) then
dosmooth=.TRUE.
if (xx_genarr3d_preproc_i(k2,iarr).NE.0)
& numsmo=xx_genarr3d_preproc_i(k2,iarr)
endif
if (xx_genarr3d_preproc(k2,iarr).EQ.'noscaling') then
doscaling=.FALSE.
endif
enddo
fnamebase = xx_genarr3d_file(iarr)
ilgen=ilnblnk( fnamebase )
write(fnamegenIn(1:80),'(2a,i10.10)')
& fnamebase(1:ilgen),'.',optimcycle
write(fnamegenOut(1:80),'(2a,i10.10)')
& fnamebase(1:ilgen),'.effective.',optimcycle
CALL MDS_READ_FIELD(xx_genarr3d_weight(iarr),ctrlprec,.FALSE.,
& 'RL',nR,1,nR,wgenarr3d(1-Olx,1-Oly,1,1,1,iarr),dummyRS,1,mythid)
#ifdef ALLOW_AUTODIFF
call ACTIVE_READ_XYZ( fnamegenIn, xx_gen, 1, doglobalread,
& ladinit, optimcycle, mythid, xx_genarr3d_dummy(iarr) )
#else
CALL READ_REC_XYZ_RL( fnamegenIn, xx_gen, 1, 1, myThid)
#endif
#ifdef ALLOW_SMOOTH
IF (useSMOOTH) THEN
IF (dowc01) call SMOOTH_CORREL3D(xx_gen,numsmo,mythid)
IF (dosmooth) call SMOOTH3D(xx_gen,numsmo,mythid)
ENDIF
#endif
#if (defined (ALLOW_UVEL0_CONTROL) defined (ALLOW_VVEL0_CONTROL))
c-- set local mask
call ECCO_ZERO(localmask,Nr,zeroRL,myThid)
if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_uvel') then
call ECCO_CPRSRL(maskW,nr,localmask,nr,myThid)
else if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_vvel') then
call ECCO_CPRSRL(maskS,nr,localmask,nr,myThid)
else
call ECCO_CPRSRL(maskC,nr,localmask,nr,myThid)
endif
#endif
DO bj=myByLo(myThid), myByHi(myThid)
DO bi=myBxLo(myThid), myBxHi(myThid)
do k = 1,nr
DO j = 1,sNy
DO i = 1,sNx
c scale param adjustment
IF (doscaling) then
#if (defined (ALLOW_UVEL0_CONTROL) defined (ALLOW_VVEL0_CONTROL))
if ( (localmask(i,j,k,bi,bj).NE.0.).AND.
#else
if ( (maskC(i,j,k,bi,bj).NE.0.).AND.
#endif
& (wgenarr3d(i,j,k,bi,bj,iarr).GT.0.) ) then
xx_gen(i,j,k,bi,bj)=xx_gen(i,j,k,bi,bj)
& /sqrt( wgenarr3d(i,j,k,bi,bj,iarr) )
else
xx_gen(i,j,k,bi,bj)=0.
endif
ENDIF
c add to model parameter
fld(i,j,k,bi,bj)=fld(i,j,k,bi,bj)+xx_gen(i,j,k,bi,bj)
enddo
enddo
enddo
enddo
enddo
c avoid param out of [boundsVec(1) boundsVec(4)]
#if (defined (ALLOW_UVEL0_CONTROL) defined (ALLOW_VVEL0_CONTROL))
CALL CTRL_BOUND_3D(fld,localmask,
& xx_genarr3d_bounds(1,iarr),myThid)
#else
CALL CTRL_BOUND_3D(fld,maskC,xx_genarr3d_bounds(1,iarr),myThid)
#endif
C The tile exchange for xx_uvel and xx_vvel will be
C done in CTRL_MAP_INI_GENARR.F when both
C xx_uvel and xx_vvel are read in.
if (xx_genarr3d_file(iarr)(1:7).NE.'xx_uvel'.AND.
& xx_genarr3d_file(iarr)(1:7).NE.'xx_vvel')
& CALL EXCH_XYZ_RL( fld, mythid )
CALL MDS_WRITE_FIELD(fnamegenOut,ctrlprec,.FALSE.,.FALSE.,
& 'RL',nr,1,nr,fld,dummyRS,1,optimcycle,mythid)
#endif /* ALLOW_GENARR3D_CONTROL */
RETURN
END