Oasis3 4.0.2
|
00001 SUBROUTINE subgrid (pfldn, pfldo, ksizn, ksizo, 00002 $ pcoar, pfine, pdqdt, 00003 $ cdfic, kunit, knumb, cdname, 00004 $ pwork, kwork, knbor, ldread, cdtype) 00005 C**** 00006 C ***************************** 00007 C * OASIS ROUTINE - LEVEL 3 * 00008 C * ------------- ------- * 00009 C ***************************** 00010 C 00011 C**** *subgrid* - submesh variabiity 00012 C 00013 C Purpose: 00014 C ------- 00015 C Interpolate with subgrid linear technique. This is rigorously 00016 C conservative if the models exchange fields at every timestep 00017 C and if sea-land mismatch is accounted for. 00018 C 00019 C** Interface: 00020 C --------- 00021 C *CALL* *subgrid (pfild, ksize, pcoar, pfine, pdqdt)* 00022 C 00023 C Input: 00024 C ----- 00025 C pfldo : initial field on source grid (real 1D) 00026 C ksizn : size of final field array (integer) 00027 C ksizo : size of initial field array (integer) 00028 C pcoar : coarse grid additional field (real 1D) 00029 C pfine : fine grid additional field (real 1D) 00030 C pdqdt : coarse grid coupling ratio (real 1D) 00031 C kunit : logical unit numbers for subgrid file (integer) 00032 C cdfic : filename for subgrid data (character) 00033 C knumb : subgrid dataset identity number (integer) 00034 C cdname : name of final field on target grid (character) 00035 C pwork : temporary array to read subgrid weights (real 1D) 00036 C kwork : temporary array to read subgrid array (integer 1D) 00037 C knbor : maximum number of source grid neighbors with non zero 00038 C intersection with a target grid-square (integer) 00039 C The source grid is here the coarse grid while the 00040 C target grid is the fine one. 00041 C ldread : logical flag to read subgrid data (logical) 00042 C cdtype : type of subgrid interpolation (character) 00043 C 00044 C Output: 00045 C ------ 00046 C pfldn : final field on target grid (real 1D) 00047 C 00048 C Workspace: 00049 C --------- 00050 C None 00051 C 00052 C Externals: 00053 C --------- 00054 C None 00055 C 00056 C Reference: 00057 C --------- 00058 C See OASIS manual (1995) 00059 C 00060 C History: 00061 C ------- 00062 C Version Programmer Date Description 00063 C ------- ---------- ---- ----------- 00064 C 2.0 L. Terray 96/02/01 created 00065 C 2.1 L. Terray 96/08/05 modified: new structure 00066 C 2.3 S. Valcke 99/04/30 added: printing levels 00067 C 00068 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00069 C 00070 C* ---------------------------- Include files --------------------------- 00071 C 00072 USE mod_unit 00073 USE mod_printing 00074 C 00075 C* ---------------------------- Argument declarations ------------------- 00076 C 00077 REAL (kind=ip_realwp_p) pfldn(ksizn), pfldo(ksizo) 00078 REAL (kind=ip_realwp_p) pcoar(ksizo), pfine(ksizn), pdqdt(ksizo) 00079 REAL (kind=ip_realwp_p) pwork(knbor,ksizn) 00080 INTEGER (kind=ip_intwp_p) kwork(knbor,ksizn) 00081 CHARACTER*8 cdfic, cdname, cdtype 00082 LOGICAL ldread 00083 C 00084 C* ---------------------------- Local declarations ---------------------- 00085 C 00086 CHARACTER*8 clweight, cladress 00087 C 00088 C* ---------------------------- Poema verses ---------------------------- 00089 C 00090 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00091 C 00092 C* 1. Initialization 00093 C -------------- 00094 C 00095 IF (nlogprt .GE. 2) THEN 00096 WRITE (UNIT = nulou,FMT = *)' ' 00097 WRITE (UNIT = nulou,FMT = *)' ROUTINE subgrid - Level 3' 00098 WRITE (UNIT = nulou,FMT = *)' *************** *******' 00099 WRITE (UNIT = nulou,FMT = *)' ' 00100 WRITE (UNIT = nulou,FMT = *)' Linear subgrid interpolation' 00101 WRITE (UNIT = nulou,FMT = *)' ' 00102 CALL FLUSH(nulou) 00103 ENDIF 00104 C 00105 C* initialize error flag for I/O routine 00106 C 00107 iflag = 0 00108 C 00109 C 00110 C* 2. Read subgrid data the first time 00111 C -------------------------------- 00112 C 00113 IF (ldread) THEN 00114 C 00115 C* Initialize locators and array sizes 00116 C 00117 WRITE(clweight,'(''WEIGHTS'',I1)') knumb 00118 WRITE(cladress,'(''ADRESSE'',I1)') knumb 00119 isize = ksizn * knbor 00120 C 00121 C* Adress of overlapped points on source grid 00122 C 00123 CALL locrint (cladress, kwork, isize, kunit, iflag) 00124 C 00125 C* Checking 00126 C 00127 IF (iflag .NE. 0) THEN 00128 CALL prcout 00129 $ ( 00130 'WARNING: problem in reading $ subgrid data for field', 00131 $ cdname, 1) 00132 CALL prcout 00133 $ ('Could not get adress array', cladress, 1) 00134 CALL prtout 00135 $ ('Error reading logical unit', kunit, 1) 00136 CALL prcout 00137 $ ('It is connected to file', cdfic, 1) 00138 CALL HALTE ('STOP in subgrid') 00139 ENDIF 00140 C 00141 C* Weights of overlapped points on source grid 00142 C 00143 CALL locread (clweight, pwork, isize, kunit, iflag) 00144 C 00145 C* Checking 00146 C 00147 IF (iflag .NE. 0) THEN 00148 CALL prcout 00149 $ ( 00150 'WARNING: problem in reading $ subgrid data for field', 00151 $ cdname, 1) 00152 CALL prcout 00153 $ ('Could not get weight array', clweight, 1) 00154 CALL prtout 00155 $ ('Error reading logical unit', kunit, 1) 00156 CALL prcout 00157 $ ('It is connected to file', cdfic, 1) 00158 CALL HALTE ('STOP in subgrid') 00159 ENDIF 00160 ldread = .FALSE. 00161 ENDIF 00162 C 00163 C 00164 C* 3. Modify main field according to type of subgrid interpolation 00165 C ------------------------------------------------------------ 00166 C* Case of non solar flux 00167 C 00168 IF (cdtype .EQ. 'NONSOLAR') THEN 00169 C 00170 C* Loop on all target points 00171 C 00172 DO 310 ji = 1, ksizn 00173 zsum = 0.0 00174 C 00175 C* Loop on active neighbors 00176 C 00177 DO 320 jk = 1, knbor 00178 IF (kwork(jk,ji) .gt. 0) then 00179 zsum = zsum + pwork(jk,ji) * 00180 $ ( pfldo(kwork(jk,ji)) + pdqdt(kwork(jk,ji)) 00181 $ * ( pfine(ji) - pcoar(kwork(jk,ji)) ) ) 00182 ENDIF 00183 320 CONTINUE 00184 pfldn(ji) = zsum 00185 310 CONTINUE 00186 C 00187 C* Case of solar flux 00188 C 00189 ELSE IF (cdtype .EQ. 'SOLAR') THEN 00190 DO 330 ji = 1, ksizn 00191 zsum = 0.0 00192 C 00193 C* Loop on active neighbors 00194 C 00195 DO 340 jk = 1, knbor 00196 IF (kwork(jk,ji) .gt. 0) then 00197 zsum = zsum + pwork(jk,ji) * pfldo(kwork(jk,ji)) * 00198 $ ( 1. - pfine(ji)) / ( 1. - pcoar(kwork(jk,ji))) 00199 ENDIF 00200 340 CONTINUE 00201 pfldn(ji) = zsum 00202 330 CONTINUE 00203 ENDIF 00204 C 00205 C 00206 C* 4. End of routine 00207 C -------------- 00208 C 00209 IF (nlogprt .GE. 2) THEN 00210 WRITE (UNIT = nulou,FMT = *) ' ' 00211 WRITE (UNIT = nulou,FMT = *) 00212 $ ' --------- End of ROUTINE subgrid ---------' 00213 CALL FLUSH (nulou) 00214 ENDIF 00215 RETURN 00216 END 00217 00218 00219 00220