Oasis3 4.0.2
|
00001 SUBROUTINE blasold (pfild ,kmsize, kfield, pmcoeff, kaux, kaddr, 00002 $ kasize, pacoeff, ksiztot, paux) 00003 C**** 00004 C ***************************** 00005 C * OASIS ROUTINE - LEVEL 3 * 00006 C * ------------- ------- * 00007 C ***************************** 00008 C 00009 C**** *blasold* - Stupid blas routine 00010 C 00011 C Purpose: 00012 C ------- 00013 C Do linear combination of fields with given coefficients 00014 C before interpolation 00015 C 00016 C** Interface: 00017 C --------- 00018 C *CALL* *blasold (pfild ,kmsize, kfield, pmcoeff, kaux, kaddr, 00019 C kasize, pacoeff, ksiztot, paux)* 00020 C 00021 C Input: 00022 C ----- 00023 C pfild : field array to be modified (real 1D) 00024 C kmsize : size of the field array (integer) 00025 C kfield : field identificator number (integer) 00026 C pmcoeff : field multiplicative coefficient (real) 00027 C kaux : number of combined auxilary fields (integer) 00028 C kaddr : pointer for auxilary fields (integer 1D) 00029 C kasize : size of auxilary fields (integer 1D) 00030 C pacoeff : auxilary field multiplicative coefficient (real 1D) 00031 C ksiztot : total size of work memory used (integer) 00032 C paux : global work array (real 1D) 00033 C 00034 C Output: 00035 C ------ 00036 C pfild : new field array (real 1D) 00037 C 00038 C Workspace: 00039 C --------- 00040 C None 00041 C 00042 C Externals: 00043 C --------- 00044 C None 00045 C 00046 C Reference: 00047 C --------- 00048 C See OASIS manual (1995) 00049 C 00050 C History: 00051 C ------- 00052 C Version Programmer Date Description 00053 C ------- ---------- ---- ----------- 00054 C 2.0 L. Terray 95/10/01 created 00055 C 2.3 S. Valcke 99/04/30 added: printing levels 00056 C 00057 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00058 C 00059 C* ---------------------------- Include files --------------------------- 00060 C 00061 USE mod_unit 00062 USE mod_printing 00063 C 00064 C* ---------------------------- Argument declarations ------------------- 00065 C 00066 REAL (kind=ip_realwp_p) pfild(kmsize) 00067 REAL (kind=ip_realwp_p) paux(ksiztot), pacoeff(kaux) 00068 INTEGER (kind=ip_intwp_p) kaddr(kaux), kasize(kaux) 00069 C 00070 C* ---------------------------- Local declarations ---------------------- 00071 C 00072 INTEGER (kind=ip_intwp_p) istop 00073 LOGICAL llchk 00074 C 00075 C* ---------------------------- Poema verses ---------------------------- 00076 C 00077 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00078 C 00079 C* 1. Initialization 00080 C -------------- 00081 C 00082 IF (nlogprt .GE. 2) THEN 00083 WRITE (UNIT = nulou,FMT = *) ' ' 00084 WRITE (UNIT = nulou,FMT = *) ' ' 00085 WRITE (UNIT = nulou,FMT = *) 00086 $ ' ROUTINE blasold - Level 3' 00087 WRITE (UNIT = nulou,FMT = *) 00088 $ ' *************** *******' 00089 WRITE (UNIT = nulou,FMT = *) ' ' 00090 WRITE (UNIT = nulou,FMT = *) 00091 $ ' Do linear combination of fields' 00092 WRITE (UNIT = nulou,FMT = *) ' ' 00093 WRITE (UNIT = nulou,FMT = *) ' ' 00094 CALL FLUSH(nulou) 00095 ENDIF 00096 istop = 0 00097 C 00098 C* Check all fields have same dimensions as current field 00099 C 00100 DO 110 jc = 1, kaux 00101 llchk = (kasize(jc) - kmsize) .EQ. 0 00102 IF (.NOT. llchk) THEN 00103 CALL prtout ( 00104 'WARNING!!! $ Pb in combining field number =', kfield, 2) 00105 CALL prtout ('Different size for auxilary field number =', 00106 $ jc, 2) 00107 istop = istop + 1 00108 ENDIF 00109 110 CONTINUE 00110 IF (istop .GT. 0) CALL HALTE('STOP in blasold') 00111 C 00112 C 00113 C* 2. Linear combination 00114 C ------------------ 00115 C 00116 C* Multiply current field by main coefficient 00117 C 00118 DO 210 ja = 1, kmsize 00119 pfild(ja) = pmcoeff * pfild(ja) 00120 210 CONTINUE 00121 C 00122 C* Combine with other fields if required 00123 C 00124 IF (kaux .GE. 1) THEN 00125 DO 220 jc = 1, kaux 00126 DO 230 ja = 1, kmsize 00127 pfild(ja) = pfild(ja) + pacoeff(jc) * 00128 $ paux(kaddr(jc)+ja-1) 00129 230 CONTINUE 00130 220 CONTINUE 00131 ENDIF 00132 C 00133 C 00134 C* 3. End of routine 00135 C -------------- 00136 C 00137 IF (nlogprt .GE. 2) THEN 00138 WRITE (UNIT = nulou,FMT = *) ' ' 00139 WRITE (UNIT = nulou,FMT = *) 00140 $ '--------- End of ROUTINE blasold ---------' 00141 CALL FLUSH (nulou) 00142 ENDIF 00143 RETURN 00144 END