Oasis3 4.0.2
|
00001 SUBROUTINE mozaic (pfldn, ksizn, pfldo, ksizo, 00002 $ cdfic, kunit, cdgrd, knumb, 00003 $ pwork, kwork, knbor, ldread) 00004 C**** 00005 C ***************************** 00006 C * OASIS ROUTINE - LEVEL 3 * 00007 C * ------------- ------- * 00008 C ***************************** 00009 C 00010 C**** *mozaic* - Mapping interpolation 00011 C 00012 C Purpose: 00013 C ------- 00014 C Do simple mapping interpolation from a source to a target grid 00015 C 00016 C** Interface: 00017 C --------- 00018 C *CALL* *mozaic (pfildn, ksizn, pfildo, ksizo, cdfic, kunit, 00019 C cdgrd. knumb, pwork, kwork, knbor, ldread)* 00020 C 00021 C Input: 00022 C ----- 00023 C pfldo : field on source grid (real 1D) 00024 C ksizn : size of field array on target grid(integer) 00025 C ksizo : size of field array on source grid(integer) 00026 C kunit : logical unit numbers for mapping file (integer) 00027 C cdfic : filename for mapping data (character) 00028 C cdgrd : locator to read mapping data in cdfic (character) 00029 C knumb : mapping dataset identity number (integer) 00030 C pwork : temporary array to read mapping weights (real 2D) 00031 C kwork : temporary array to read mapping array (integer 2D) 00032 C knbor : maximum number of source grid neighbors with non zero 00033 C intersection with a target grid-square (integer) 00034 C ldread : logical flag to read mapping data 00035 C 00036 C Output: 00037 C ------ 00038 C pfldn : field on target grid (real 1D) 00039 C 00040 C Workspace: 00041 C --------- 00042 C None 00043 C 00044 C Externals: 00045 C --------- 00046 C locrint 00047 C 00048 C Reference: 00049 C --------- 00050 C See OASIS manual (1995) 00051 C 00052 C History: 00053 C ------- 00054 C Version Programmer Date Description 00055 C ------- ---------- ---- ----------- 00056 C 2.0 L. Terray 96/02/01 created 00057 C 2.1 L. Terray 96/08/05 modified: Add logical flag to 00058 C read adresses and weights 00059 C 2.3 S. Valcke 99/04/30 added: printing levels 00060 C 2.4 S. Valcke 2K/02/05 corrected for overflow pfldo(0) 00061 C 00062 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00063 C 00064 C* ---------------------------- Include files --------------------------- 00065 C 00066 USE mod_unit 00067 USE mod_printing 00068 C 00069 C* ---------------------------- Argument declarations ------------------- 00070 C 00071 REAL (kind=ip_realwp_p) pfldn(ksizn), pfldo(ksizo), 00072 $ pwork(knbor,ksizn) 00073 INTEGER (kind=ip_intwp_p) kwork(knbor,ksizn) 00074 CHARACTER*8 cdfic, cdgrd 00075 LOGICAL ldread 00076 C 00077 C* ---------------------------- Local declarations ---------------------- 00078 C 00079 CHARACTER*8 clweight, cladress 00080 C 00081 C* ---------------------------- Poema verses ---------------------------- 00082 C 00083 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00084 C 00085 C* 1. Initialization 00086 C -------------- 00087 C 00088 IF (nlogprt .GE. 2) THEN 00089 WRITE (UNIT = nulou,FMT = *)' ' 00090 WRITE (UNIT = nulou,FMT = *)' ROUTINE mozaic - Level 3' 00091 WRITE (UNIT = nulou,FMT = *)' ************** *******' 00092 WRITE (UNIT = nulou,FMT = *)' ' 00093 WRITE (UNIT = nulou,FMT = *)' grid mapping interpolation' 00094 WRITE (UNIT = nulou,FMT = *) ' ' 00095 CALL FLUSH(nulou) 00096 ENDIF 00097 C 00098 C* initialize error flag for I/O routine 00099 C 00100 iflag = 0 00101 C 00102 C 00103 C* 2. Read mapping data the first time 00104 C -------------------------------- 00105 C 00106 IF (ldread) THEN 00107 C 00108 C* Initialize locators and array sizes 00109 C 00110 WRITE(clweight,'(''WEIGHTS'',I1)') knumb 00111 WRITE(cladress,'(''ADRESSE'',I1)') knumb 00112 isize = ksizn * knbor 00113 C 00114 C* Adress of overlapped points on source grid 00115 C 00116 CALL locrint (cladress, kwork, isize, kunit, iflag) 00117 C 00118 C* Checking 00119 C 00120 IF (iflag .NE. 0) THEN 00121 CALL prcout 00122 $ ('WARNING: problem in reading mapping data', 00123 $ cdgrd, 1) 00124 CALL prcout 00125 $ ('Could not get adress array', cladress, 1) 00126 CALL prtout 00127 $ ('Error reading logical unit', kunit, 1) 00128 CALL prcout 00129 $ ('It is connected to file', cdfic, 1) 00130 CALL HALTE ('STOP in mozaic') 00131 ENDIF 00132 C 00133 C* Weights of overlapped points on source grid 00134 C 00135 CALL locread (clweight, pwork, isize, kunit, iflag) 00136 C 00137 C* Checking 00138 C 00139 IF (iflag .NE. 0) THEN 00140 CALL prcout 00141 $ ('WARNING: problem in reading mapping data', 00142 $ cdgrd, 1) 00143 CALL prcout 00144 $ ('Could not get weight array', clweight, 1) 00145 CALL prtout 00146 $ ('Error reading logical unit', kunit, 1) 00147 CALL prcout 00148 $ ('It is connected to file', cdfic, 1) 00149 CALL HALTE ('STOP in mozaic') 00150 ENDIF 00151 ldread = .FALSE. 00152 ENDIF 00153 C 00154 C 00155 C* 3. Do the mapping interpolation 00156 C ---------------------------- 00157 C 00158 C* Loop on all the target grid points 00159 C 00160 DO 310 ji = 1, ksizn 00161 zsum = 0. 00162 DO 320 jk = 1, knbor 00163 IF (kwork(jk,ji) .NE. 0) 00164 $ zsum = zsum + pwork(jk,ji) * pfldo(kwork(jk,ji)) 00165 320 CONTINUE 00166 pfldn(ji) = zsum 00167 310 CONTINUE 00168 C 00169 C 00170 C* 4. End of routine 00171 C -------------- 00172 C 00173 IF (nlogprt .GE. 2) THEN 00174 WRITE (UNIT = nulou,FMT = *) ' ' 00175 WRITE (UNIT = nulou,FMT = *) 00176 $ ' --------- End of ROUTINE mozaic ---------' 00177 CALL FLUSH (nulou) 00178 ENDIF 00179 RETURN 00180 END