Back to home page

MITgcm
 
 

    

File indexing completed on 2021-09-17 05:16:51 UTC

view on githubraw file Latest commit 13d362b8 on 2021-09-16 18:57:16 UTC
24462d2fa8 Patr*0001 #include "PROFILES_OPTIONS.h"
5a362746b1 Gael*0002 #ifdef ALLOW_ECCO
                0003 # include "ECCO_OPTIONS.h"
                0004 #endif
6a770e0a24 Patr*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,
39ce977435 Gael*0015      I i_cur,
                0016      I j_cur,
                0017      I weights_cur,
cf16ba6028 Gael*0018      I var_cur,
                0019      I itr_cur,
6a770e0a24 Patr*0020      I file_cur,
13d362b8c1 Ou W*0021      I myTime,
71a5587721 Gael*0022      I bi,
                0023      I bj,
6a770e0a24 Patr*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"
24462d2fa8 Patr*0035 #ifdef ALLOW_CAL
5a362746b1 Gael*0036 # include "cal.h"
                0037 #endif
                0038 #ifdef ALLOW_ECCO
13d362b8c1 Ou W*0039 # include "ECCO_SIZE.h"
                0040 # include "ECCO.h"
24462d2fa8 Patr*0041 #endif
d28c90138c Patr*0042 #ifdef ALLOW_PROFILES
6328b73337 Gael*0043 # include "PROFILES_SIZE.h"
6e4c90fea3 Patr*0044 # include "profiles.h"
                0045 #endif
7cad2d9e22 Gael*0046 #ifdef ALLOW_PTRACERS
                0047 #include "PTRACERS_SIZE.h"
1e24424557 Jean*0048 #include "PTRACERS_FIELDS.h"
7cad2d9e22 Gael*0049 #endif
6a770e0a24 Patr*0050 C ==================== Routine Variables ==========================
13d362b8c1 Ou W*0051       _RL  myTime
                0052       integer myThid
cf16ba6028 Gael*0053       integer file_cur, itr_cur
                0054       character*(8) var_cur
5a362746b1 Gael*0055 #ifndef ALLOW_PROFILES
                0056       _RL  traj_cur_out, weights_cur
                0057       integer  i_cur, j_cur
                0058 #else
6e4c90fea3 Patr*0059       _RL  traj_cur_out(NLEVELMAX)
39ce977435 Gael*0060       _RL  weights_cur(NUM_INTERP_POINTS)
                0061       integer  i_cur(NUM_INTERP_POINTS)
                0062       integer  j_cur(NUM_INTERP_POINTS)
5a362746b1 Gael*0063 #endif
6e4c90fea3 Patr*0064 
                0065 C ==================== Local Variables ==========================
39ce977435 Gael*0066       _RL tab_coeffs1(NUM_INTERP_POINTS)
                0067       _RL tab_coeffs3(NUM_INTERP_POINTS)
                0068       _RL ponderations(NUM_INTERP_POINTS),pondsSUM
                0069       integer q,k,kk,kcur,bi,bj
6e4c90fea3 Patr*0070       _RL traj_cur(nR),mask_cur(nR)
39ce977435 Gael*0071       _RL tmp_coeff
3c8dcfdea9 Gael*0072 
                0073 c     == external functions ==
                0074       integer ILNBLNK
                0075       EXTERNAL ILNBLNK
                0076 
6a770e0a24 Patr*0077 c--   == end of interface ==
                0078 
39ce977435 Gael*0079 c horizontal interpolation:
                0080       do k=1,nr
                0081         pondsSUM=0. _d 0
                0082         do q=1,NUM_INTERP_POINTS
                0083         if (var_cur.EQ.'theta') then
                0084                tab_coeffs1(q)=theta(i_cur(q),j_cur(q),k,bi,bj)
                0085         elseif (var_cur.EQ.'salt') then
                0086                tab_coeffs1(q)=salt(i_cur(q),j_cur(q),k,bi,bj)
                0087         elseif (var_cur.EQ.'pTracer') then
7cad2d9e22 Gael*0088 #ifdef ALLOW_PTRACERS
39ce977435 Gael*0089                tab_coeffs1(q)=pTracer(i_cur(q),j_cur(q),k,bi,bj,
                0090      &            itr_cur)
7cad2d9e22 Gael*0091 #else
39ce977435 Gael*0092                tab_coeffs1(q)=0. _d 0
7cad2d9e22 Gael*0093 #endif
5a362746b1 Gael*0094 #ifdef ALLOW_ECCO
                0095         elseif (var_cur.EQ.'eta') then
                0096                tab_coeffs1(q)=m_eta(i_cur(q),j_cur(q),bi,bj)
da0e0765ef An T*0097 #endif
5a362746b1 Gael*0098         elseif (var_cur.EQ.'UE') then
                0099                tab_coeffs1(q)=m_UE(i_cur(q),j_cur(q),k,bi,bj)
                0100         elseif (var_cur.EQ.'VN') then
                0101                tab_coeffs1(q)=m_VN(i_cur(q),j_cur(q),k,bi,bj)
6a770e0a24 Patr*0102         else
39ce977435 Gael*0103                tab_coeffs1(q)=0. _d 0
6a770e0a24 Patr*0104         endif
39ce977435 Gael*0105         tab_coeffs3(q)=maskC(i_cur(q),j_cur(q),k,bi,bj)
6a770e0a24 Patr*0106 
39ce977435 Gael*0107         ponderations(q)=tab_coeffs3(q)*weights_cur(q)
                0108         pondsSUM=pondsSUM+ponderations(q)
                0109         enddo
f527c11034 Gael*0110 
                0111         if (pondsSUM.GT.0) then
39ce977435 Gael*0112          traj_cur(k)=0. _d 0
                0113          mask_cur(k)=1. _d 0
                0114          do q=1,NUM_INTERP_POINTS
                0115            traj_cur(k)=traj_cur(k)
                0116      &     +tab_coeffs1(q)*ponderations(q)/pondsSUM
                0117          enddo
f527c11034 Gael*0118         else
39ce977435 Gael*0119          traj_cur(k)=0. _d 0
                0120          mask_cur(k)=0. _d 0
f527c11034 Gael*0121         endif
39ce977435 Gael*0122       enddo
6a770e0a24 Patr*0123 
39ce977435 Gael*0124 c vertical interpolation:
6a770e0a24 Patr*0125       do kk=1,NLEVELMAX
                0126          traj_cur_out(kk)=0
71a5587721 Gael*0127          prof_mask1D_cur(kk,bi,bj)=0
6a770e0a24 Patr*0128       enddo
71a5587721 Gael*0129       do kk=1,ProfDepthNo(file_cur,bi,bj)
af9e0d08c7 Jean*0130 c case 1: above first grid center=> first grid center value
71a5587721 Gael*0131         if (prof_depth(file_cur,kk,bi,bj).LT.-rC(1)) then
f527c11034 Gael*0132           traj_cur_out(kk)=traj_cur(1)
71a5587721 Gael*0133           prof_mask1D_cur(kk,bi,bj)=mask_cur(1)
f527c11034 Gael*0134 c case 2: just below last grid center=> last cell value
71a5587721 Gael*0135         elseif (prof_depth(file_cur,kk,bi,bj).GE.-rC(nr)) then
af9e0d08c7 Jean*0136           if ( prof_depth(file_cur,kk,bi,bj) .LT.
                0137      &    (-rC(nr)+drC(nr)/2) ) then
f527c11034 Gael*0138             traj_cur_out(kk)=traj_cur(nr)
71a5587721 Gael*0139             prof_mask1D_cur(kk,bi,bj)=mask_cur(nr)
f527c11034 Gael*0140           endif
6a770e0a24 Patr*0141 c case 3: between two grid centers
f527c11034 Gael*0142         else
                0143           kcur=0
                0144           do k=1,nr-1
71a5587721 Gael*0145             if ((prof_depth(file_cur,kk,bi,bj).GE.-rC(k)).AND.
                0146      &      (prof_depth(file_cur,kk,bi,bj).LT.-rC(k+1))) then
f527c11034 Gael*0147               kcur=k
                0148             endif
                0149           enddo
                0150           if (kcur.EQ.0) then
46ae49c2d0 Gael*0151             WRITE(errorMessageUnit,'(A)')
b00d6c1700 Gael*0152      &        'ERROR in PROFILES_INTERP: unexpected case 1'
                0153             CALL ALL_PROC_DIE( myThid )
                0154             STOP 'ABNORMAL END: S/R PROFILES_INTERP'
f527c11034 Gael*0155           endif
                0156           if (mask_cur(kcur+1).EQ.1.) then
                0157 c  subcase 1: 2 wet points=>linear interpolation
71a5587721 Gael*0158             tmp_coeff=(prof_depth(file_cur,kk,bi,bj)+rC(kcur))/
f527c11034 Gael*0159      &      (-rC(kcur+1)+rC(kcur))
                0160             traj_cur_out(kk)=(1-tmp_coeff)*traj_cur(kcur)
                0161      &      +tmp_coeff*traj_cur(kcur+1)
71a5587721 Gael*0162             prof_mask1D_cur(kk,bi,bj)=1
f527c11034 Gael*0163             if (mask_cur(kcur).EQ.0.) then
46ae49c2d0 Gael*0164             WRITE(errorMessageUnit,'(A)')
b00d6c1700 Gael*0165      &        'ERROR in PROFILES_INTERP: unexpected case 2'
                0166             CALL ALL_PROC_DIE( myThid )
                0167             STOP 'ABNORMAL END: S/R PROFILES_INTERP'
f527c11034 Gael*0168             endif
71a5587721 Gael*0169           elseif (prof_depth(file_cur,kk,bi,bj).LT.-rF(kcur+1)) then
f527c11034 Gael*0170 c  subcase 2: only 1 wet point just above=>upper cell value
                0171             traj_cur_out(kk)=traj_cur(kcur)
71a5587721 Gael*0172             prof_mask1D_cur(kk,bi,bj)=mask_cur(kcur)
f527c11034 Gael*0173           endif
                0174         endif
6a770e0a24 Patr*0175       enddo
                0176 
af9e0d08c7 Jean*0177       RETURN
                0178       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!