Warning, /pkg/regrid/regrid_scalar_out.template is written in an unsupported language. File is not indexed.
view on githubraw file Latest commit 5237154b on 2024-08-28 14:56:27 UTC
aa076db465 Ed H*0001 #include "REGRID_OPTIONS.h"
0002
0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
0004 CBOP 0
0005 C !ROUTINE: REGRID_SCALAR_RX_OUT
0006
0007 C !INTERFACE:
5237154b93 Jean*0008 SUBROUTINE REGRID_SCALAR_RX_OUT(
0009 I mnc_bname, igout, var, vname, nz, izlev,
aa076db465 Ed H*0010 I myThid )
0011
0012 C !DESCRIPTION:
0013 C Perform simple 2D scalar regrid and write the result to the
0014 C specified file
0015
0016 C !USES:
0017 IMPLICIT NONE
0018 #include "SIZE.h"
0019 #include "EEPARAMS.h"
0020 #include "PARAMS.h"
0021 #include "REGRID_SIZE.h"
0022 #include "REGRID.h"
0023
0024 C !INPUT PARAMETERS:
0025 C igout :: index of output grid to use
0026 C var :: variable on "standard" model grid
0027 C vname :: variable name
0028 C nz :: number of z levels
0029 C izlev :: index vector of z levels
0030 C myThid :: my thread Id number
0031 INTEGER nz
0032 __V var(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nz,nSx,nSy)
0033 CHARACTER*(*) mnc_bname
0034 CHARACTER*(*) vname
0035 INTEGER izlev(nz)
0036 INTEGER igout, myThid
0037 CEOP
0038
0039 C !LOCAL VARIABLES:
5237154b93 Jean*0040 C msgBuf - Informational/error message buffer
aa076db465 Ed H*0041 INTEGER ILNBLNK
0042 EXTERNAL ILNBLNK
0043 C CHARACTER*(MAX_LEN_MBUF) msgBuf
0044 INTEGER iz, bi,bj, ii,ind, nval, nnb
5237154b93 Jean*0045 _RL ptsums(REGRID_NELEM_MAX,nSx,nSy)
0046 _RL glsums(REGRID_NELEM_MAX)
aa076db465 Ed H*0047 #ifdef ALLOW_MNC
0048 INTEGER CW_DIMS, NLEN
0049 PARAMETER ( CW_DIMS = 10 )
0050 PARAMETER ( NLEN = 80 )
0051 INTEGER offsets(CW_DIMS)
0052 INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
0053 CHARACTER*(NLEN) dn(CW_DIMS)
0054 CHARACTER*(NLEN) regrid_vname
0055 CHARACTER*(NLEN) d_cw_name
0056 CHARACTER*(NLEN) dn_blnk
0057 #endif /* ALLOW_MNC */
0058 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
0059
0060 DO ii = 1,CW_DIMS
0061 offsets(ii) = 0
0062 ENDDO
0063
0064 C =============================================
0065 C Create the MNC definition for the variable
0066 #ifdef ALLOW_MNC
0067 _BEGIN_MASTER( myThid )
0068 #ifdef ALLOW_USE_MPI
0069 IF ( mpiMyId .EQ. 0 ) THEN
0070 #endif /* ALLOW_USE_MPI */
5237154b93 Jean*0071
aa076db465 Ed H*0072 bi = myBxLo(myThid)
0073 bj = myByLo(myThid)
5237154b93 Jean*0074
aa076db465 Ed H*0075 IF (useMNC .AND. regrid_mnc) THEN
0076
0077 DO ii = 1,NLEN
0078 dn_blnk(ii:ii) = ' '
0079 ENDDO
0080
0081 dn(1)(1:NLEN) = dn_blnk(1:NLEN)
0082 WRITE(dn(1),'(a,i6.6)') 'Zrgl_', nz
0083 dim(1) = nz
0084 ib(1) = 1
0085 ie(1) = nz
5237154b93 Jean*0086
aa076db465 Ed H*0087 CALL MNC_CW_ADD_GNAME('regrid_levels', 1,
0088 & dim, dn, ib, ie, myThid)
0089 CALL MNC_CW_ADD_VNAME('regrid_levels', 'regrid_levels',
0090 & 0,0, myThid)
0091 CALL MNC_CW_ADD_VATTR_TEXT('regrid_levels','description',
0092 & 'Idicies of vertical levels within the source arrays',
0093 & myThid)
5237154b93 Jean*0094
aa076db465 Ed H*0095 CALL MNC_CW_I_W('I',mnc_bname,bi,bj,
0096 & 'regrid_levels', izlev, myThid)
0097
0098 CALL MNC_CW_DEL_VNAME('regrid_levels', myThid)
0099 CALL MNC_CW_DEL_GNAME('regrid_levels', myThid)
0100
0101 d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
0102 DO ii = 1,CW_DIMS
0103 dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
0104 ENDDO
5237154b93 Jean*0105
aa076db465 Ed H*0106 C All the horizontal dimensions of the output grid are flattened
0107 C into a single total-DoF vector.
0108 WRITE(dn(1),'(a,i10.10)') 'regrid_', regrid_nout(igout)
0109 dim(1) = regrid_nout(igout)
0110 ib(1) = 1
0111 ie(1) = regrid_nout(igout)
0112
0113 C Vertical dimension
0114 dn(2)(1:NLEN) = dn_blnk(1:NLEN)
0115 WRITE(dn(2),'(a,i6.6)') 'Zrgl_', nz
0116 dim(2) = nz
0117 ib(2) = 1
0118 ie(2) = nz
0119
0120 C Time dimension
0121 dn(3)(1:1) = 'T'
0122 dim(3) = -1
0123 ib(3) = 1
0124 ie(3) = 1
0125
0126 C Generate unique grid names
0127 WRITE(d_cw_name,'(a3,i3.3,a1,i3.3)') 'rg_',igout,'_',nz
0128
0129 CALL MNC_CW_ADD_GNAME(d_cw_name, 3,
0130 & dim, dn, ib, ie, myThid)
0131 regrid_vname(1:NLEN) = dn_blnk(1:NLEN)
0132 write(regrid_vname,'(a,a)') 'regrid_', vname
0133 CALL MNC_CW_ADD_VNAME(regrid_vname, d_cw_name,
0134 & 0,0, myThid)
0135 C CALL MNC_CW_ADD_VATTR_TEXT(vname,'units','-',myThid)
0136
0137 ENDIF
0138
0139 #ifdef ALLOW_USE_MPI
0140 ENDIF
0141 #endif /* ALLOW_USE_MPI */
0142 _END_MASTER( myThid )
0143 _BARRIER
0144 #endif /* ALLOW_MNC */
0145
0146 C =============================================
0147 C Empty the per-thread vectors for all possible threads
0148 _BEGIN_MASTER( myThid )
0149 DO bj = 1,nSy
0150 DO bi = 1,nSx
0151 DO ind = 1,regrid_nout(igout)
0152 ptsums( ind, bi,bj ) = 0. _d 0
0153 ENDDO
0154 ENDDO
0155 ENDDO
0156 _END_MASTER( myThid )
0157 _BARRIER
0158
0159 C =============================================
0160 C Compute the distributed sparse matrix multiply
0161 DO iz = 1,nz
0162
0163 DO bj = myByLo(myThid), myByHi(myThid)
0164 DO bi = myBxLo(myThid), myBxHi(myThid)
0165
0166 DO ind = 1,regrid_nout(igout)
0167 ptsums( ind, bi,bj ) = 0. _d 0
0168 ENDDO
0169
0170 C Compute the per-thread partial sums
0171 DO ind = regrid_ibeg(igout,bi,bj),regrid_iend(igout,bi,bj)
0172 ptsums( regrid_i_out(ind,bi,bj), bi,bj ) =
5237154b93 Jean*0173 & ptsums( regrid_i_out(ind,bi,bj), bi,bj )
aa076db465 Ed H*0174 & + regrid_amat(ind,bi,bj)
5237154b93 Jean*0175 & * var( regrid_i_loc(ind,bi,bj),
aa076db465 Ed H*0176 & regrid_j_loc(ind,bi,bj), izlev(iz), bi,bj)
0177 ENDDO
5237154b93 Jean*0178
aa076db465 Ed H*0179 C Sum over all threads and MPI processes
0180 nval = regrid_nout(igout)
5237154b93 Jean*0181
aa076db465 Ed H*0182 ENDDO
0183 ENDDO
0184
0185 _BARRIER
0186
5237154b93 Jean*0187 CALL GLOBAL_SUM_VEC_ALT_RL( REGRID_NELEM_MAX, nval, ptsums,
0188 & glsums, myThid )
0189
aa076db465 Ed H*0190 C At this point, we have the global sum. The master thread of the
0191 C lead MPI process should now write the output.
0192 _BEGIN_MASTER( myThid )
0193 #ifdef ALLOW_USE_MPI
0194 IF ( mpiMyId .EQ. 0 ) THEN
0195 #endif /* ALLOW_USE_MPI */
0196
0197 offsets(2) = iz
5237154b93 Jean*0198 CALL MNC_CW_RL_W_OFFSET( 'D', mnc_bname, 1, 1,
0199 & regrid_vname, glsums, offsets, myThid )
0200
aa076db465 Ed H*0201 #ifdef ALLOW_USE_MPI
0202 ENDIF
0203 #endif /* ALLOW_USE_MPI */
0204 _END_MASTER( myThid )
0205 _BARRIER
0206
0207 ENDDO /* iz */
5237154b93 Jean*0208
aa076db465 Ed H*0209 CALL MNC_CW_DEL_VNAME(regrid_vname, myThid)
0210 CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
0211
0212 RETURN
0213 END
