Back to home page

MITgcm
 
 

    

File indexing completed on 2023-05-28 05:11:05 UTC

view on githubraw file Latest commit b4daa243 on 2023-05-28 03:53:22 UTC
b4daa24319 Shre*0001 #include "PROFILES_OPTIONS.h"
                0002 #ifdef ALLOW_ECCO
                0003 # include "ECCO_OPTIONS.h"
                0004 #endif
                0005 
                0006 C     o==========================================================o
                0007 C     | subroutine profiles_interp                               |
                0008 C     | o 3D interpolation of model counterparts                 |
                0009 C     |   for netcdf profiles data                               |
                0010 C     | started: Gael Forget 15-March-2006                       |
                0011 C     o==========================================================o
                0012 
                0013       SUBROUTINE profiles_interp(
                0014      O traj_cur_out,
                0015      I i_cur,
                0016      I j_cur,
                0017      I weights_cur,
                0018      I var_cur,
                0019      I itr_cur,
                0020      I file_cur,
                0021      I myTime,
                0022      I bi,
                0023      I bj,
                0024      I myThid
                0025      & )
                0026 
                0027       implicit none
                0028 
                0029 C ==================== Global Variables ===========================
                0030 #include "EEPARAMS.h"
                0031 #include "SIZE.h"
                0032 #include "GRID.h"
                0033 #include "DYNVARS.h"
                0034 #include "PARAMS.h"
                0035 #ifdef ALLOW_CAL
                0036 # include "cal.h"
                0037 #endif
                0038 #ifdef ALLOW_ECCO
                0039 # include "ECCO_SIZE.h"
                0040 # include "ECCO.h"
                0041 #endif
                0042 #ifdef ALLOW_PROFILES
                0043 # include "PROFILES_SIZE.h"
                0044 # include "profiles.h"
                0045 #endif
                0046 #ifdef ALLOW_PTRACERS
                0047 #include "PTRACERS_SIZE.h"
                0048 #include "PTRACERS_FIELDS.h"
                0049 #endif
                0050 #ifdef ALLOW_BLING
                0051 #include "BLING_VARS.h"
                0052 #endif
                0053 C ==================== Routine Variables ==========================
                0054       _RL  myTime
                0055       integer myThid
                0056       integer file_cur, itr_cur
                0057       character*(8) var_cur
                0058 #ifndef ALLOW_PROFILES
                0059       _RL  traj_cur_out, weights_cur
                0060       integer  i_cur, j_cur
                0061 #else
                0062       _RL  traj_cur_out(NLEVELMAX)
                0063       _RL  weights_cur(NUM_INTERP_POINTS)
                0064       integer  i_cur(NUM_INTERP_POINTS)
                0065       integer  j_cur(NUM_INTERP_POINTS)
                0066 #endif
                0067 
                0068 C ==================== Local Variables ==========================
                0069       _RL tab_coeffs1(NUM_INTERP_POINTS)
                0070       _RL tab_coeffs3(NUM_INTERP_POINTS)
                0071       _RL ponderations(NUM_INTERP_POINTS),pondsSUM
                0072       integer q,k,kk,kcur,bi,bj
                0073       _RL traj_cur(nR),mask_cur(nR)
                0074       _RL tmp_coeff
                0075 
                0076 c     == external functions ==
                0077       integer ILNBLNK
                0078       EXTERNAL ILNBLNK
                0079 
                0080 c--   == end of interface ==
                0081 
                0082 c horizontal interpolation:
                0083       do k=1,nr
                0084         pondsSUM=0. _d 0
                0085         do q=1,NUM_INTERP_POINTS
                0086         if (var_cur.EQ.'theta') then
                0087                tab_coeffs1(q)=theta(i_cur(q),j_cur(q),k,bi,bj)
                0088         elseif (var_cur.EQ.'salt') then
                0089                tab_coeffs1(q)=salt(i_cur(q),j_cur(q),k,bi,bj)
                0090         elseif (var_cur.EQ.'pTracer') then
                0091 #ifdef ALLOW_PTRACERS
                0092                tab_coeffs1(q)=pTracer(i_cur(q),j_cur(q),k,bi,bj,
                0093      &            itr_cur)
                0094 #else
                0095                tab_coeffs1(q)=0. _d 0
                0096 #endif
                0097 #ifdef ALLOW_BLING
                0098         elseif (var_cur.EQ.'PCO') then
                0099                tab_coeffs1(q)=pCO2(i_cur(q),j_cur(q),bi,bj)
                0100         elseif (var_cur.EQ.'PH') then
                0101                tab_coeffs1(q)=pH(i_cur(q),j_cur(q),k,bi,bj)
                0102         elseif (var_cur.EQ.'CHL') then
                0103                tab_coeffs1(q)=CHL(i_cur(q),j_cur(q),k,bi,bj)
                0104         elseif (var_cur.EQ.'POC') then
                0105                tab_coeffs1(q)=POC(i_cur(q),j_cur(q),k,bi,bj)
                0106 #endif
                0107 #ifdef ALLOW_ECCO
                0108         elseif (var_cur.EQ.'eta') then
                0109                tab_coeffs1(q)=m_eta(i_cur(q),j_cur(q),bi,bj)
                0110 #endif
                0111         elseif (var_cur.EQ.'UE') then
                0112                tab_coeffs1(q)=m_UE(i_cur(q),j_cur(q),k,bi,bj)
                0113         elseif (var_cur.EQ.'VN') then
                0114                tab_coeffs1(q)=m_VN(i_cur(q),j_cur(q),k,bi,bj)
                0115         else
                0116                tab_coeffs1(q)=0. _d 0
                0117         endif
                0118         tab_coeffs3(q)=maskC(i_cur(q),j_cur(q),k,bi,bj)
                0119 
                0120         ponderations(q)=tab_coeffs3(q)*weights_cur(q)
                0121         pondsSUM=pondsSUM+ponderations(q)
                0122         enddo
                0123 
                0124         if (pondsSUM.GT.0) then
                0125          traj_cur(k)=0. _d 0
                0126          mask_cur(k)=1. _d 0
                0127          do q=1,NUM_INTERP_POINTS
                0128            traj_cur(k)=traj_cur(k)
                0129      &     +tab_coeffs1(q)*ponderations(q)/pondsSUM
                0130          enddo
                0131         else
                0132          traj_cur(k)=0. _d 0
                0133          mask_cur(k)=0. _d 0
                0134         endif
                0135       enddo
                0136 
                0137 c vertical interpolation:
                0138       do kk=1,NLEVELMAX
                0139          traj_cur_out(kk)=0
                0140          prof_mask1D_cur(kk,bi,bj)=0
                0141       enddo
                0142       do kk=1,ProfDepthNo(file_cur,bi,bj)
                0143 c case 1: above first grid center=> first grid center value
                0144         if (prof_depth(file_cur,kk,bi,bj).LT.-rC(1)) then
                0145           traj_cur_out(kk)=traj_cur(1)
                0146           prof_mask1D_cur(kk,bi,bj)=mask_cur(1)
                0147 c case 2: just below last grid center=> last cell value
                0148         elseif (prof_depth(file_cur,kk,bi,bj).GE.-rC(nr)) then
                0149           if ( prof_depth(file_cur,kk,bi,bj) .LT.
                0150      &    (-rC(nr)+drC(nr)/2) ) then
                0151             traj_cur_out(kk)=traj_cur(nr)
                0152             prof_mask1D_cur(kk,bi,bj)=mask_cur(nr)
                0153           endif
                0154 c case 3: between two grid centers
                0155         else
                0156           kcur=0
                0157           do k=1,nr-1
                0158             if ((prof_depth(file_cur,kk,bi,bj).GE.-rC(k)).AND.
                0159      &      (prof_depth(file_cur,kk,bi,bj).LT.-rC(k+1))) then
                0160               kcur=k
                0161             endif
                0162           enddo
                0163           if (kcur.EQ.0) then
                0164             WRITE(errorMessageUnit,'(A)')
                0165      &        'ERROR in PROFILES_INTERP: unexpected case 1'
                0166             CALL ALL_PROC_DIE( myThid )
                0167             STOP 'ABNORMAL END: S/R PROFILES_INTERP'
                0168           endif
                0169           if (mask_cur(kcur+1).EQ.1.) then
                0170 c  subcase 1: 2 wet points=>linear interpolation
                0171             tmp_coeff=(prof_depth(file_cur,kk,bi,bj)+rC(kcur))/
                0172      &      (-rC(kcur+1)+rC(kcur))
                0173             traj_cur_out(kk)=(1-tmp_coeff)*traj_cur(kcur)
                0174      &      +tmp_coeff*traj_cur(kcur+1)
                0175             prof_mask1D_cur(kk,bi,bj)=1
                0176             if (mask_cur(kcur).EQ.0.) then
                0177             WRITE(errorMessageUnit,'(A)')
                0178      &        'ERROR in PROFILES_INTERP: unexpected case 2'
                0179             CALL ALL_PROC_DIE( myThid )
                0180             STOP 'ABNORMAL END: S/R PROFILES_INTERP'
                0181             endif
                0182           elseif (prof_depth(file_cur,kk,bi,bj).LT.-rF(kcur+1)) then
                0183 c  subcase 2: only 1 wet point just above=>upper cell value
                0184             traj_cur_out(kk)=traj_cur(kcur)
                0185             prof_mask1D_cur(kk,bi,bj)=mask_cur(kcur)
                0186           endif
                0187         endif
                0188       enddo
                0189 
                0190       RETURN
                0191       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!