pkg/profiles/profiles_readvector.F

24462d2fa8 Patr*0001 #include "PROFILES_OPTIONS.h"
6a770e0a24 Patr*0002
                0003 C     o==========================================================o
                0004 C     | subroutine profiles_readvector                           |
98bf704dd5 Jean*0005 C     | o reads a profile from a netcdf profiles data file       |
6a770e0a24 Patr*0006 C     | started: Gael Forget 15-March-2006                       |
                0007 C     o==========================================================o
                0008
98bf704dd5 Jean*0009       SUBROUTINE profiles_readvector(fNb, vNb, irec,
71a5587721 Gael*0010      & vec_loc_length, vec_loc , bi,bj, myThid)
6a770e0a24 Patr*0011
                0012       implicit none
                0013
                0014 C ==================== Global Variables ===========================
                0015 #include "SIZE.h"
275a56dc21 Gael*0016 #include "EEPARAMS.h"
                0017 #include "PARAMS.h"
6a770e0a24 Patr*0018 #include "GRID.h"
                0019 #include "DYNVARS.h"
d28c90138c Patr*0020 #ifdef ALLOW_PROFILES
6328b73337 Gael*0021 # include "netcdf.inc"
                0022 # include "PROFILES_SIZE.h"
                0023 # include "profiles.h"
6e4c90fea3 Patr*0024 #endif
6a770e0a24 Patr*0025 C ==================== Routine Variables ==========================
71a5587721 Gael*0026       integer vec_loc_length, vNb, k, kk, kkk,bi,bj
6a770e0a24 Patr*0027       integer irec, fNb, myThid,err,varid1,tmpprofno
                0028       _RL vec_loc(vec_loc_length)
6e4c90fea3 Patr*0029
d28c90138c Patr*0030 #ifdef ALLOW_PROFILES
6e4c90fea3 Patr*0031
6a770e0a24 Patr*0032       integer vec_start(2),vec_count(2)
                0033       _RL vec_tmp1(1000*NLEVELMAX),vec_tmp2(1000*NLEVELMAX)
6b2230d510 Ou W*0034 #ifdef ALLOW_PROFILES_CLIMMASK
                0035       _RL vec_tmp3(1000*NLEVELMAX)
                0036 #endif
ce2e1d3cd5 Patr*0037       character*(max_len_mbuf) msgbuf
                0038
6a770e0a24 Patr*0039 c--   == end of interface ==
                0040
                0041
71a5587721 Gael*0042       if ( (irec.LT.profiles_minind_buff(bi,bj)).OR.
                0043      &  (irec.GT.profiles_maxind_buff(bi,bj)).OR.
                0044      & (profiles_curfile_buff(bi,bj).NE.fNb) ) then
                0045       err = NF_INQ_DIMID(fiddata(fNb,bi,bj),'iPROF', varid1)
                0046       err = NF_INQ_DIMLEN(fiddata(fNb,bi,bj), varid1, tmpprofno)
6a770e0a24 Patr*0047
71a5587721 Gael*0048       if (profiles_curfile_buff(bi,bj).NE.fNb) then
6a770e0a24 Patr*0049 c no asumption on whether a forward or a backward loop is calling
71a5587721 Gael*0050       profiles_minind_buff(bi,bj)=max(1,irec-500+1)
                0051       profiles_maxind_buff(bi,bj)=min(tmpprofno,irec+500)
                0052       elseif (irec.LT.profiles_minind_buff(bi,bj)) then
98bf704dd5 Jean*0053 c implies that a backward loop is calling
71a5587721 Gael*0054       profiles_minind_buff(bi,bj)=max(1,irec-999)
                0055       profiles_maxind_buff(bi,bj)=irec
6a770e0a24 Patr*0056       else
                0057 c implies that a forward loop is calling
71a5587721 Gael*0058       profiles_minind_buff(bi,bj)=irec
                0059       profiles_maxind_buff(bi,bj)=min(tmpprofno,irec+999)
6a770e0a24 Patr*0060       endif
                0061
275a56dc21 Gael*0062 #ifdef ALLOW_DEBUG
                0063       IF ( debugLevel .GE. debLevD ) THEN
ce2e1d3cd5 Patr*0064       write(msgbuf,'(a,5I9)')
                0065      &   'buffer readvector ',
                0066      &   profiles_minind_buff(bi,bj), profiles_maxind_buff(bi,bj),
                0067      &   irec, profNo(fNb,bi,bj), tmpprofno
                0068       call print_message(
98bf704dd5 Jean*0069      &   msgbuf, standardmessageunit, SQUEEZE_RIGHT , mythid)
275a56dc21 Gael*0070       ENDIF
                0071 #endif
6a770e0a24 Patr*0072
                0073       vec_start(1)=1
71a5587721 Gael*0074       vec_start(2)=profiles_minind_buff(bi,bj)
6a770e0a24 Patr*0075       vec_count(1)=vec_loc_length
71a5587721 Gael*0076       vec_count(2)=
                0077      & profiles_maxind_buff(bi,bj)-profiles_minind_buff(bi,bj)+1
6a770e0a24 Patr*0078
ea4d09597a Gael*0079       do kkk=1,NVARMAX
71a5587721 Gael*0080       if (vec_quantities(fNb,kkk,bi,bj).EQV..TRUE.) then
cf16ba6028 Gael*0081       err = NF_INQ_VARID(fiddata(fNb,bi,bj),prof_names(fNb,kkk),
71a5587721 Gael*0082      & varid1 )
98bf704dd5 Jean*0083       err = NF_GET_VARA_DOUBLE(fiddata(fNb,bi,bj), varid1 , vec_start,
6e4c90fea3 Patr*0084      & vec_count, vec_tmp1)
cf16ba6028 Gael*0085       err = NF_INQ_VARID(fiddata(fNb,bi,bj),prof_namesweight(fNb,kkk)
71a5587721 Gael*0086      & , varid1 )
98bf704dd5 Jean*0087       err = NF_GET_VARA_DOUBLE(fiddata(fNb,bi,bj), varid1 , vec_start,
6e4c90fea3 Patr*0088      & vec_count, vec_tmp2)
6b2230d510 Ou W*0089 #ifdef ALLOW_PROFILES_CLIMMASK
                0090       err = NF_INQ_VARID(fiddata(fNb,bi,bj),prof_namesclim(fNb,kkk)
                0091      & , varid1 )
                0092       err = NF_GET_VARA_DOUBLE(fiddata(fNb,bi,bj), varid1 , vec_start,
                0093      & vec_count, vec_tmp3)
                0094 #endif
6a770e0a24 Patr*0095
                0096       if (err.NE.NF_NOERR) then
46ae49c2d0 Gael*0097             WRITE(errorMessageUnit,'(A)')
                0098      & 'WARNING in profiles_readvector: record not found!!'
6a770e0a24 Patr*0099       endif
                0100
98bf704dd5 Jean*0101       do k=1,vec_count(1)
                0102       do kk=1,vec_count(2)
71a5587721 Gael*0103       profiles_data_buff(k,kk,kkk,bi,bj)=vec_tmp1((kk-1)*vec_count(1)+k)
                0104       profiles_weight_buff(k,kk,kkk,bi,bj)=vec_tmp2((kk-1)*vec_count(1)
                0105      & +k)
6b2230d510 Ou W*0106 #ifdef ALLOW_PROFILES_CLIMMASK
                0107       if(vec_tmp3((kk-1)*vec_count(1)+k).LE.-990. _d 0)
                0108      &    profiles_weight_buff(k,kk,kkk,bi,bj) = 0. _d 0
                0109 #endif
6a770e0a24 Patr*0110       enddo
98bf704dd5 Jean*0111       enddo
6a770e0a24 Patr*0112       endif
                0113       enddo
                0114
71a5587721 Gael*0115       profiles_curfile_buff(bi,bj)=fNb
6a770e0a24 Patr*0116       endif
                0117
                0118 cgf ...now, get vec_loc from the buffer
                0119       if (vNb.LT.0) then
                0120            do k=1,vec_loc_length
71a5587721 Gael*0121            vec_loc(k)= profiles_weight_buff
                0122      & (k,irec-profiles_minind_buff(bi,bj)+1,-vNb,bi,bj)
6a770e0a24 Patr*0123            enddo
                0124
                0125        else
                0126            do k=1,vec_loc_length
71a5587721 Gael*0127            vec_loc(k)=profiles_data_buff
                0128      & (k,irec-profiles_minind_buff(bi,bj)+1,vNb,bi,bj)
6a770e0a24 Patr*0129            enddo
98bf704dd5 Jean*0130        endif
6a770e0a24 Patr*0131
6e4c90fea3 Patr*0132 #endif
6a770e0a24 Patr*0133
                0134       END