Oasis3 4.0.2
|
00001 SUBROUTINE correct (pfild, ksize, pmcoef, kaux, pacoef, pwork, 00002 $ kunit, cdfic, cdfld) 00003 C**** 00004 C ***************************** 00005 C * OASIS ROUTINE - LEVEL 3 * 00006 C * ------------- ------- * 00007 C ***************************** 00008 C 00009 C**** *correct* - Flux correction routine 00010 C 00011 C Purpose: 00012 C ------- 00013 C Use external data to modify coupling fields 00014 C 00015 C** Interface: 00016 C --------- 00017 C *CALL* *correct (pfild, ksize, pmcoef, kaux, pacoef, pwork, 00018 C kunit, cdfic, cdfld)* 00019 C 00020 C Input: 00021 C ----- 00022 C pfild : field on source grid (real 1D) 00023 C ksize : size of field array (integer) 00024 C pmcoef : main field coefficient (real) 00025 C kaux : number of auxilary fields (integer) 00026 C pacoef : auxilary field coefficients (real 1D) 00027 C pwork : temporary array to read auxilary fields (real 1D) 00028 C kunit : logical unit numbers for data files (INTEGER 1D) 00029 C cdfic : filenames for external data (character 1D) 00030 C cdfld : auxilary field names (character 1D) 00031 C 00032 C Output: 00033 C ------ 00034 C pfild : corrected field on source grid (real 1D) 00035 C 00036 C Workspace: 00037 C --------- 00038 C None 00039 C 00040 C Externals: 00041 C --------- 00042 C None 00043 C 00044 C Reference: 00045 C --------- 00046 C See OASIS manual (1995) 00047 C 00048 C History: 00049 C ------- 00050 C Version Programmer Date Description 00051 C ------- ---------- ---- ----------- 00052 C 2.0 L. Terray 95/10/01 created 00053 C 2.3 S. Valcke 99/04/30 added: printing levels 00054 C 00055 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00056 C 00057 C* ---------------------------- Include files --------------------------- 00058 C 00059 USE mod_unit 00060 USE mod_printing 00061 C 00062 C* ---------------------------- Argument declarations ------------------- 00063 C 00064 REAL (kind=ip_realwp_p) pfild(ksize), pwork(ksize), pacoef(kaux) 00065 INTEGER (kind=ip_intwp_p) kunit(kaux) 00066 CHARACTER*8 cdfic(kaux), cdfld(kaux) 00067 C 00068 C* ---------------------------- Local declarations ---------------------- 00069 C 00070 CHARACTER*8 clfic 00071 C 00072 C* ---------------------------- Poema verses ---------------------------- 00073 C 00074 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00075 C 00076 C* 1. Initialization 00077 C -------------- 00078 C 00079 IF (nlogprt .GE. 2) THEN 00080 WRITE (UNIT = nulou,FMT = *) ' ' 00081 WRITE (UNIT = nulou,FMT = *) ' ' 00082 WRITE (UNIT = nulou,FMT = *) 00083 $ ' ROUTINE correct - Level 3' 00084 WRITE (UNIT = nulou,FMT = *) 00085 $ ' *************** *******' 00086 WRITE (UNIT = nulou,FMT = *) ' ' 00087 WRITE (UNIT = nulou,FMT = *) 00088 $ ' Flux correction with external data' 00089 WRITE (UNIT = nulou,FMT = *) ' ' 00090 CALL FLUSH(nulou) 00091 ENDIF 00092 C 00093 C* initialize error flag for I/O routine 00094 C 00095 iflag = 0 00096 C 00097 C 00098 C* 2. Multiply main field by its coefficient 00099 C -------------------------------------- 00100 C 00101 DO 210 ji = 1, ksize 00102 pfild(ji) = pfild(ji) * pmcoef 00103 210 CONTINUE 00104 C 00105 C 00106 C* 3. Read external data and add it to main field 00107 C ------------------------------------------- 00108 C 00109 C* Loop on additional fields 00110 C 00111 DO 310 ji = 1, kaux 00112 C 00113 C* Flush data files 00114 C 00115 iunit = kunit(ji) 00116 clfic = cdfic(ji) 00117 CLOSE(UNIT = iunit, ERR = 3010, IOSTAT = ios) 00118 WRITE(UNIT = nulou, FMT = 3100) iunit, clfic 00119 3010 CONTINUE 00120 IF (ios .NE. 0) THEN 00121 CALL prtout('WARNING: problem in closing unit', 00122 $ iunit, 1) 00123 CALL prtout('Error message number is = ', ios, 1) 00124 CALL HALTE('STOP in correct') 00125 ENDIF 00126 OPEN(UNIT=iunit,FILE=clfic,FORM='UNFORMATTED', 00127 $ STATUS='UNKNOWN',ERR = 3020, IOSTAT = ios) 00128 WRITE(UNIT = nulou, FMT = 3200) iunit, clfic 00129 3020 CONTINUE 00130 IF (ios .NE. 0) THEN 00131 CALL prtout('WARNING: problem in connecting unit', 00132 $ iunit, 1) 00133 CALL prtout('Error message number is = ', ios, 1) 00134 CALL HALTE('STOP in correct') 00135 ENDIF 00136 C 00137 C* Reading of the auxilary fields 00138 C 00139 CALL locread (cdfld(ji), pwork, ksize, kunit(ji), iflag) 00140 C 00141 C* Checking 00142 C 00143 IF (iflag .NE. 0) THEN 00144 CALL prcout 00145 $ ('WARNING: problem in reading field', 00146 $ cdfld(ji), 1) 00147 CALL prtout 00148 $ ('Error reading logical unit', kunit(ji), 1) 00149 CALL prcout 00150 $ ('It is connected to file',cdfic(ji),1) 00151 WRITE(UNIT = nulou,FMT = *) 00152 $ ' If very first iteration and parallel simulation ' 00153 WRITE(UNIT = nulou,FMT = *) 00154 $ ' or sequential one starting with atmosphere ' 00155 WRITE(UNIT = nulou,FMT = *) 00156 $ ' No file present !! It is normal !! ' 00157 00158 ENDIF 00159 C 00160 C* Add to original field 00161 C 00162 DO 320 jj = 1, ksize 00163 pfild(jj) = pfild(jj) + pacoef(ji) * pwork(jj) 00164 320 CONTINUE 00165 310 CONTINUE 00166 C 00167 C* Formats 00168 C 00169 3100 FORMAT(/,5X,' Unit ',I2,' has been disconnected from file ',A8) 00170 3200 FORMAT(/,5X,' Unit ',I2,' has been reconnected to file ',A8) 00171 C 00172 C 00173 C* 4. End of routine 00174 C -------------- 00175 C 00176 IF (nlogprt .GE. 2) THEN 00177 WRITE (UNIT = nulou,FMT = *) ' ' 00178 WRITE (UNIT = nulou,FMT = *) 00179 $ ' --------- End of ROUTINE correct ---------' 00180 CALL FLUSH (nulou) 00181 ENDIF 00182 RETURN 00183 END