|
Oasis3 4.0.2
|
|
Oasis3 4.0.2
|
00001 00002 MODULE mathelp_psmile 00003 !--------------------------------------------------------------------- 00004 ! 00005 ! Reiner Vogelsang, SGI, 27 April 2003 00006 ! - Screening of 4 byte real interfaces in case a of dbl4 compilation. 00007 ! File has to be preprocessed with -D__SXdbl4. 00008 ! 00009 ! 00010 !--------------------------------------------------------------------- 00011 #include "psmile_os.h" 00012 00013 USE errioipsl_psmile,ONLY : histerr 00014 USE stringop_psmile 00015 !- 00016 PRIVATE 00017 PUBLIC :: mathop,moycum,trans_buff,buildop 00018 !- 00019 INTERFACE buildop 00020 #ifndef __NO_4BYTE_REALS 00021 MODULE PROCEDURE buildop_r4 00022 #endif 00023 MODULE PROCEDURE buildop_r8 00024 end INTERFACE 00025 00026 INTERFACE mathop 00027 #ifndef __NO_4BYTE_REALS 00028 MODULE PROCEDURE mathop_r114 00029 #endif 00030 MODULE PROCEDURE mathop_r118 00031 END INTERFACE 00032 00033 INTERFACE moycum 00034 #ifndef __NO_4BYTE_REALS 00035 MODULE PROCEDURE moycum_r4 00036 #endif 00037 MODULE PROCEDURE moycum_r8 00038 end INTERFACE 00039 00040 !- 00041 !- Variables used to detect and identify the operations 00042 !- 00043 CHARACTER(LEN=80),SAVE :: 00044 seps='( ) , + - / * ^', ops = '+ - * / ^', mima = 'min max' 00045 CHARACTER(LEN=250),SAVE :: 00046 funcs = 'sin cos tan asin acos atan exp log sqrt chs abs '& 00047 //'cels kelv deg rad gather scatter fill coll undef only ident' 00048 CHARACTER(LEN=120),SAVE :: 00049 indexfu = 'gather, scatter, fill, coll, undef, only' 00050 !--------------------------------------------------------------------- 00051 CONTAINS 00052 != 00053 SUBROUTINE buildop_r4 (str,ex_topps,topp,nbops_max, & 00054 & missing_val,opps,scal,nbops) 00055 !--------------------------------------------------------------------- 00056 !- This subroutine decomposes the input string in the elementary 00057 !- functions which need to be applied to the vector of data. 00058 !- This vector is represented by X in the string. 00059 !- This subroutine is the driver of the decomposition and gets 00060 !- the time operation but then call decoop for the other operations 00061 !- 00062 !- INPUT 00063 !- 00064 !- str : String containing the operations 00065 !- ex_toops : The time operations that can be expected within the string 00066 !- 00067 !- OUTPUT 00068 !- 00069 !--------------------------------------------------------------------- 00070 USE mod_comprism_proto 00071 IMPLICIT NONE 00072 !- 00073 CHARACTER*80 ::str 00074 CHARACTER*(*) :: ex_topps 00075 CHARACTER*7 :: topp 00076 INTEGER (kind=ip_intwp_p) :: nbops_max,nbops 00077 INTEGER (kind=ip_intwp_p), PARAMETER :: ierrh=3 00078 CHARACTER*7 :: opps(nbops_max) 00079 REAL (kind=ip_single_p) :: scal(nbops_max),missing_val 00080 !- 00081 CHARACTER*80 :: new_str 00082 INTEGER (kind=ip_intwp_p) :: leng,ind_opb,ind_clb 00083 !- 00084 LOGICAL :: check = .FALSE. 00085 !--------------------------------------------------------------------- 00086 ! 00087 IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning' 00088 !- 00089 leng = LEN_TRIM(str) 00090 IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN 00091 str = str(2:leng-1) 00092 leng = leng-2 00093 ENDIF 00094 !- 00095 IF (check) & 00096 & WRITE(*,*) 'buildop : Starting to test the various options' 00097 !- 00098 IF (leng <= 5 .AND. INDEX(ex_topps,str(1:leng)) > 0) THEN 00099 IF (check) WRITE(*,*) 'buildop : Time operation only' 00100 nbops = 0 00101 topp = str(1:leng) 00102 ELSE 00103 IF (check) WRITE(*,*) 'buildop : Time operation and something else' 00104 !--- 00105 ind_opb = INDEX(str(1:leng),'(') 00106 IF (ind_opb > 0) THEN 00107 IF ( INDEX(ex_topps,str(1:ind_opb-1)) > 0) THEN 00108 IF (check) WRITE(*,'(2a)') & 00109 & ' buildop : Extract time operation from : ',str 00110 topp = str(1:ind_opb-1) 00111 ind_clb = INDEX(str(1:leng),')',BACK=.TRUE.) 00112 new_str = str(ind_opb+1:ind_clb-1) 00113 IF (check) WRITE(*,'(2a,2I3)') & 00114 & ' buildop : Call decoop ',new_str,ind_opb,ind_clb 00115 CALL decoop_r4 (new_str,nbops_max,missing_val,opps,scal,nbops) 00116 ELSE 00117 CALL histerr(ierrh,'buildop','time opperation does not exist',str(1:ind_opb-1),' ') 00118 ENDIF 00119 ELSE 00120 CALL histerr(ierrh,'buildop','some long opperation exists but wihout parenthesis',str(1:leng),' ') 00121 ENDIF 00122 ENDIF 00123 !- 00124 IF (check) THEN 00125 DO leng=1,nbops 00126 WRITE(*,*) 'buildop : i -- opps, scal : ',leng,opps(leng),scal(leng) 00127 ENDDO 00128 ENDIF 00129 ! 00130 !------------------------ 00131 END SUBROUTINE buildop_r4 00132 != 00133 SUBROUTINE buildop_r8 (str,ex_topps,topp,nbops_max, & 00134 & missing_val,opps,scal,nbops) 00135 !--------------------------------------------------------------------- 00136 !- This subroutine decomposes the input string in the elementary 00137 !- functions which need to be applied to the vector of data. 00138 !- This vector is represented by X in the string. 00139 !- This subroutine is the driver of the decomposition and gets 00140 !- the time operation but then call decoop for the other operations 00141 !- 00142 !- INPUT 00143 !- 00144 !- str : String containing the operations 00145 !- ex_toops : The time operations that can be expected within the string 00146 !- 00147 !- OUTPUT 00148 !- 00149 !--------------------------------------------------------------------- 00150 USE mod_comprism_proto 00151 IMPLICIT NONE 00152 !- 00153 CHARACTER*80 ::str 00154 CHARACTER*(*) :: ex_topps 00155 CHARACTER*7 :: topp 00156 INTEGER (kind=ip_intwp_p) :: nbops_max,nbops 00157 INTEGER (kind=ip_intwp_p) ,PARAMETER :: ierrh=3 00158 CHARACTER*7 :: opps(nbops_max) 00159 REAL (kind=ip_double_p) :: scal(nbops_max),missing_val 00160 !- 00161 CHARACTER*80 :: new_str 00162 INTEGER (kind=ip_intwp_p) :: leng,ind_opb,ind_clb 00163 !- 00164 LOGICAL :: check = .FALSE. 00165 !--------------------------------------------------------------------- 00166 ! 00167 IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning' 00168 00169 !- 00170 leng = LEN_TRIM(str) 00171 IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN 00172 str = str(2:leng-1) 00173 leng = leng-2 00174 ENDIF 00175 !- 00176 IF (check) & 00177 & WRITE(*,*) 'buildop : Starting to test the various options' 00178 !- 00179 IF (leng <= 5 .AND. INDEX(ex_topps,str(1:leng)) > 0) THEN 00180 IF (check) WRITE(*,*) 'buildop : Time operation only' 00181 nbops = 0 00182 topp = str(1:leng) 00183 ELSE 00184 IF (check) WRITE(*,*) 'buildop : Time operation and something else' 00185 !--- 00186 ind_opb = INDEX(str(1:leng),'(') 00187 IF (ind_opb > 0) THEN 00188 IF ( INDEX(ex_topps,str(1:ind_opb-1)) > 0) THEN 00189 IF (check) WRITE(*,'(2a)') & 00190 & ' buildop : Extract time operation from : ',str 00191 topp = str(1:ind_opb-1) 00192 ind_clb = INDEX(str(1:leng),')',BACK=.TRUE.) 00193 new_str = str(ind_opb+1:ind_clb-1) 00194 IF (check) WRITE(*,'(2a,2I3)') & 00195 & ' buildop : Call decoop ',new_str,ind_opb,ind_clb 00196 CALL decoop_r8 (new_str,nbops_max,missing_val,opps,scal,nbops) 00197 ELSE 00198 CALL histerr(ierrh,'buildop','time opperation does not exist',str(1:ind_opb-1),' ') 00199 ENDIF 00200 ELSE 00201 CALL histerr(ierrh,'buildop','some long opperation exists but wihout parenthesis',str(1:leng),' ') 00202 ENDIF 00203 ENDIF 00204 !- 00205 IF (check) THEN 00206 DO leng=1,nbops 00207 WRITE(*,*) 'buildop : i -- opps, scal : ',leng,opps(leng),scal(leng) 00208 ENDDO 00209 ENDIF 00210 ! 00211 !------------------------ 00212 END SUBROUTINE buildop_r8 00213 != 00214 SUBROUTINE decoop_r4 (pstr,nbops_max,missing_val,opps,scal,nbops) 00215 !--------------------------------------------------------------------- 00216 USE mod_comprism_proto 00217 IMPLICIT NONE 00218 !- 00219 CHARACTER*80 :: pstr 00220 INTEGER (kind=ip_intwp_p) :: nbops_max,nbops 00221 INTEGER (kind=ip_intwp_p) ,PARAMETER :: ierrh=3 00222 CHARACTER*7 :: opps(nbops_max) 00223 REAL (kind=ip_single_p) :: scal(nbops_max),missing_val 00224 !- 00225 CHARACTER*1 :: f_char(2),s_char(2) 00226 INTEGER (kind=ip_intwp_p) :: nbsep,f_pos(2),s_pos(2) 00227 CHARACTER*20 :: opp_str,scal_str 00228 CHARACTER*80 :: str 00229 INTEGER (kind=ip_intwp_p) :: xpos,leng,ppos,epos,int_tmp 00230 CHARACTER*3 :: tl,dl 00231 CHARACTER*10 :: fmt 00232 !- 00233 LOGICAL :: check = .FALSE.,prio 00234 !--------------------------------------------------------------------- 00235 ! 00236 IF (check) WRITE(*,'(2a)') ' decoop : Incoming string : ',pstr 00237 !- 00238 nbops = 0 00239 str = pstr 00240 !- 00241 CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos) 00242 IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep 00243 DO WHILE (nbsep > 0) 00244 xpos = INDEX(str,'X') 00245 leng = LEN_TRIM(str) 00246 nbops = nbops+1 00247 !--- 00248 IF (check) THEN 00249 WRITE(*,*) 'decoop : str -->',str(1:leng) 00250 WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2) 00251 WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2) 00252 ENDIF 00253 !--- 00254 IF (nbops > nbops_max-1) THEN 00255 CALL histerr(ierrh,'decoop','Expression too complex',str,' ') 00256 ENDIF 00257 !--- 00258 IF (check) WRITE(*,*) 'decoop : --',nbops,' ',str(1:leng) 00259 !--- 00260 !--- Start the analysis of the syntax. 3 types of constructs 00261 !--- are recognized. They are scanned sequentialy 00262 !--- 00263 IF (nbsep == 1) THEN 00264 IF (check) WRITE(*,*) 'decoop : Only one operation' 00265 IF (INDEX(ops,f_char(1)) > 0) THEN 00266 !------- 00267 !------- Type : scal+X 00268 !------- 00269 IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN 00270 opp_str = f_char(1)//'I' 00271 ELSE 00272 opp_str = f_char(1) 00273 ENDIF 00274 scal_str = str(s_pos(1)+1:f_pos(1)-1) 00275 str = 'X' 00276 ELSE IF (INDEX(ops,f_char(2)) > 0) THEN 00277 !------- 00278 !------- Type : X+scal 00279 !------- 00280 opp_str = f_char(2) 00281 scal_str = str(f_pos(2)+1:s_pos(2)-1) 00282 str = 'X' 00283 ELSE 00284 CALL histerr(ierrh,'decoop','Unknown operations of type X+scal',f_char(1),pstr) 00285 ENDIF 00286 ELSE 00287 IF (check) WRITE(*,*) 'decoop : More complex operation' 00288 IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN 00289 !------- 00290 !------- Type : sin(X) 00291 !------- 00292 opp_str = str(s_pos(1)+1:f_pos(1)-1) 00293 scal_str = '?' 00294 str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng) 00295 ELSE IF ( (f_char(1) == '(' .AND. f_char(2) == ',')& 00296 & .OR.(f_char(1) == ',' .AND. f_char(2) == ')')) THEN 00297 !------- 00298 !------- Type : max(X,scal) or max(scal,X) 00299 !------- 00300 IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN 00301 !--------- 00302 !--------- Type : max(X,scal) 00303 !--------- 00304 opp_str = str(f_pos(1)-3:f_pos(1)-1) 00305 scal_str = str(f_pos(2)+1:s_pos(2)-1) 00306 str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng) 00307 ELSE IF (f_char(1) == ',' .AND. s_char(1) == '(') THEN 00308 !--------- 00309 !--------- Type : max(scal,X) 00310 !--------- 00311 opp_str = str(s_pos(1)-3:s_pos(1)-1) 00312 scal_str = str(s_pos(1)+1:f_pos(1)-1) 00313 str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng) 00314 ELSE 00315 CALL histerr(ierrh,'decoop','Syntax error 1',str,' ') 00316 ENDIF 00317 ELSE 00318 prio = (f_char(2) == '*').OR.(f_char(2) == '^') 00319 IF ( (INDEX(ops,f_char(1)) > 0) & 00320 & .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN 00321 !--------- 00322 !--------- Type : ... scal+X ... 00323 !--------- 00324 IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN 00325 opp_str = f_char(1)//'I' 00326 ELSE 00327 opp_str = f_char(1) 00328 ENDIF 00329 scal_str = str(s_pos(1)+1:f_pos(1)-1) 00330 str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng) 00331 ELSE IF ( (INDEX(ops,f_char(2)) > 0) & 00332 & .AND.(f_pos(2)-xpos == 1) ) THEN 00333 !--------- 00334 !--------- Type : ... X+scal ... 00335 !--------- 00336 opp_str = f_char(2) 00337 scal_str = str(f_pos(2)+1:s_pos(2)-1) 00338 str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng) 00339 ELSE 00340 CALL histerr(ierrh,'decoop','Syntax error 2',str,' ') 00341 ENDIF 00342 ENDIF 00343 ENDIF 00344 !--- 00345 IF (check) WRITE(*,*) 'decoop : Finished syntax,str = ',str(1:LEN_TRIM(str)) 00346 !----- 00347 !----- Now that the different components of the operation are identified 00348 !----- we transform them into what is going to be used in the program 00349 !----- 00350 IF (INDEX(scal_str,'?') > 0) THEN 00351 IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN 00352 opps(nbops) = opp_str(1:LEN_TRIM(opp_str)) 00353 scal(nbops) = missing_val 00354 ELSE 00355 CALL histerr(ierrh,'decoop','Unknown function',opp_str(1:LEN_TRIM(opp_str)),' ') 00356 ENDIF 00357 ELSE 00358 leng = LEN_TRIM(opp_str) 00359 IF (INDEX(mima,opp_str(1:leng)) > 0) THEN 00360 opps(nbops) = 'fu'//opp_str(1:leng) 00361 ELSE 00362 IF (INDEX(opp_str(1:leng),'+') > 0) THEN 00363 opps(nbops) = 'add' 00364 ELSE IF (INDEX(opp_str(1:leng),'-I') > 0) THEN 00365 opps(nbops) = 'subi' 00366 ELSE IF (INDEX(opp_str(1:leng),'-') > 0) THEN 00367 opps(nbops) = 'sub' 00368 ELSE IF (INDEX(opp_str(1:leng),'*') > 0) THEN 00369 opps(nbops) = 'mult' 00370 ELSE IF (INDEX(opp_str(1:leng),'/') > 0) THEN 00371 opps(nbops) = 'div' 00372 ELSE IF (INDEX(opp_str(1:leng),'/I') > 0) THEN 00373 opps(nbops) = 'divi' 00374 ELSE IF (INDEX(opp_str(1:leng),'^') > 0) THEN 00375 opps(nbops) = 'power' 00376 ELSE 00377 CALL histerr(ierrh,'decoop','Unknown operation',opp_str(1:leng),' ') 00378 ENDIF 00379 ENDIF 00380 !----- 00381 leng = LEN_TRIM(scal_str) 00382 ppos = INDEX(scal_str,'.') 00383 epos = INDEX(scal_str,'e') 00384 IF (epos == 0) epos = INDEX(scal_str,'E') 00385 !----- 00386 !----- Try to catch a few errors 00387 !----- 00388 IF (INDEX(ops,scal_str) > 0) THEN 00389 CALL histerr(ierrh,'decoop','Strange scalar you have here ',scal_str,pstr) 00390 ENDIF 00391 IF (epos > 0) THEN 00392 WRITE(tl,'(I3.3)') leng 00393 WRITE(dl,'(I3.3)') epos-ppos-1 00394 fmt='(e'//tl//'.'//dl//')' 00395 READ(scal_str,fmt) scal(nbops) 00396 ELSE IF (ppos > 0) THEN 00397 WRITE(tl,'(I3.3)') leng 00398 WRITE(dl,'(I3.3)') leng-ppos 00399 fmt='(f'//tl//'.'//dl//')' 00400 READ(scal_str,fmt) scal(nbops) 00401 ELSE 00402 WRITE(tl,'(I3.3)') leng 00403 fmt = '(I'//tl//')' 00404 READ(scal_str,fmt) int_tmp 00405 scal(nbops) = REAL(int_tmp, kind=ip_single_p) 00406 ENDIF 00407 ENDIF 00408 IF (check) WRITE(*,*) 'decoop : Finished interpretation' 00409 CALL findsep(str,nbsep,f_char,f_pos,s_char,s_pos) 00410 ENDDO 00411 ! 00412 !----------------------- 00413 END SUBROUTINE decoop_r4 00414 != 00415 SUBROUTINE decoop_r8 (pstr,nbops_max,missing_val,opps,scal,nbops) 00416 !--------------------------------------------------------------------- 00417 USE mod_comprism_proto 00418 IMPLICIT NONE 00419 !- 00420 CHARACTER*80 :: pstr 00421 INTEGER (kind=ip_intwp_p) :: nbops_max,nbops 00422 INTEGER (kind=ip_intwp_p) ,PARAMETER :: ierrh=3 00423 CHARACTER*7 :: opps(nbops_max) 00424 REAL (kind=ip_double_p) :: scal(nbops_max),missing_val 00425 !- 00426 CHARACTER*1 :: f_char(2),s_char(2) 00427 INTEGER (kind=ip_intwp_p) :: nbsep,f_pos(2),s_pos(2) 00428 CHARACTER*20 :: opp_str,scal_str 00429 CHARACTER*80 :: str 00430 INTEGER (kind=ip_intwp_p) :: xpos,leng,ppos,epos,int_tmp 00431 CHARACTER*3 :: tl,dl 00432 CHARACTER*10 :: fmt 00433 !- 00434 LOGICAL :: check = .FALSE.,prio 00435 !--------------------------------------------------------------------- 00436 ! 00437 IF (check) WRITE(*,'(2a)') ' decoop : Incoming string : ',pstr 00438 !- 00439 nbops = 0 00440 str = pstr 00441 !- 00442 CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos) 00443 IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep 00444 DO WHILE (nbsep > 0) 00445 xpos = INDEX(str,'X') 00446 leng = LEN_TRIM(str) 00447 nbops = nbops+1 00448 !--- 00449 IF (check) THEN 00450 WRITE(*,*) 'decoop : str -->',str(1:leng) 00451 WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2) 00452 WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2) 00453 ENDIF 00454 !--- 00455 IF (nbops > nbops_max-1) THEN 00456 CALL histerr(ierrh,'decoop','Expression too complex',str,' ') 00457 ENDIF 00458 !--- 00459 IF (check) WRITE(*,*) 'decoop : --',nbops,' ',str(1:leng) 00460 !--- 00461 !--- Start the analysis of the syntax. 3 types of constructs 00462 !--- are recognized. They are scanned sequentialy 00463 !--- 00464 IF (nbsep == 1) THEN 00465 IF (check) WRITE(*,*) 'decoop : Only one operation' 00466 IF (INDEX(ops,f_char(1)) > 0) THEN 00467 !------- 00468 !------- Type : scal+X 00469 !------- 00470 IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN 00471 opp_str = f_char(1)//'I' 00472 ELSE 00473 opp_str = f_char(1) 00474 ENDIF 00475 scal_str = str(s_pos(1)+1:f_pos(1)-1) 00476 str = 'X' 00477 ELSE IF (INDEX(ops,f_char(2)) > 0) THEN 00478 !------- 00479 !------- Type : X+scal 00480 !------- 00481 opp_str = f_char(2) 00482 scal_str = str(f_pos(2)+1:s_pos(2)-1) 00483 str = 'X' 00484 ELSE 00485 CALL histerr(ierrh,'decoop','Unknown operations of type X+scal',f_char(1),pstr) 00486 ENDIF 00487 ELSE 00488 IF (check) WRITE(*,*) 'decoop : More complex operation' 00489 IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN 00490 !------- 00491 !------- Type : sin(X) 00492 !------- 00493 opp_str = str(s_pos(1)+1:f_pos(1)-1) 00494 scal_str = '?' 00495 str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng) 00496 ELSE IF ( (f_char(1) == '(' .AND. f_char(2) == ',')& 00497 & .OR.(f_char(1) == ',' .AND. f_char(2) == ')')) THEN 00498 !------- 00499 !------- Type : max(X,scal) or max(scal,X) 00500 !------- 00501 IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN 00502 !--------- 00503 !--------- Type : max(X,scal) 00504 !--------- 00505 opp_str = str(f_pos(1)-3:f_pos(1)-1) 00506 scal_str = str(f_pos(2)+1:s_pos(2)-1) 00507 str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng) 00508 ELSE IF (f_char(1) == ',' .AND. s_char(1) == '(') THEN 00509 !--------- 00510 !--------- Type : max(scal,X) 00511 !--------- 00512 opp_str = str(s_pos(1)-3:s_pos(1)-1) 00513 scal_str = str(s_pos(1)+1:f_pos(1)-1) 00514 str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng) 00515 ELSE 00516 CALL histerr(ierrh,'decoop','Syntax error 1',str,' ') 00517 ENDIF 00518 ELSE 00519 prio = (f_char(2) == '*').OR.(f_char(2) == '^') 00520 IF ( (INDEX(ops,f_char(1)) > 0) & 00521 & .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN 00522 !--------- 00523 !--------- Type : ... scal+X ... 00524 !--------- 00525 IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN 00526 opp_str = f_char(1)//'I' 00527 ELSE 00528 opp_str = f_char(1) 00529 ENDIF 00530 scal_str = str(s_pos(1)+1:f_pos(1)-1) 00531 str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng) 00532 ELSE IF ( (INDEX(ops,f_char(2)) > 0) & 00533 & .AND.(f_pos(2)-xpos == 1) ) THEN 00534 !--------- 00535 !--------- Type : ... X+scal ... 00536 !--------- 00537 opp_str = f_char(2) 00538 scal_str = str(f_pos(2)+1:s_pos(2)-1) 00539 str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng) 00540 ELSE 00541 CALL histerr(ierrh,'decoop','Syntax error 2',str,' ') 00542 ENDIF 00543 ENDIF 00544 ENDIF 00545 !--- 00546 IF (check) WRITE(*,*) 'decoop : Finished syntax,str = ',str(1:LEN_TRIM(str)) 00547 !----- 00548 !----- Now that the different components of the operation are identified 00549 !----- we transform them into what is going to be used in the program 00550 !----- 00551 IF (INDEX(scal_str,'?') > 0) THEN 00552 IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN 00553 opps(nbops) = opp_str(1:LEN_TRIM(opp_str)) 00554 scal(nbops) = missing_val 00555 ELSE 00556 CALL histerr(ierrh,'decoop','Unknown function',opp_str(1:LEN_TRIM(opp_str)),' ') 00557 ENDIF 00558 ELSE 00559 leng = LEN_TRIM(opp_str) 00560 IF (INDEX(mima,opp_str(1:leng)) > 0) THEN 00561 opps(nbops) = 'fu'//opp_str(1:leng) 00562 ELSE 00563 IF (INDEX(opp_str(1:leng),'+') > 0) THEN 00564 opps(nbops) = 'add' 00565 ELSE IF (INDEX(opp_str(1:leng),'-I') > 0) THEN 00566 opps(nbops) = 'subi' 00567 ELSE IF (INDEX(opp_str(1:leng),'-') > 0) THEN 00568 opps(nbops) = 'sub' 00569 ELSE IF (INDEX(opp_str(1:leng),'*') > 0) THEN 00570 opps(nbops) = 'mult' 00571 ELSE IF (INDEX(opp_str(1:leng),'/') > 0) THEN 00572 opps(nbops) = 'div' 00573 ELSE IF (INDEX(opp_str(1:leng),'/I') > 0) THEN 00574 opps(nbops) = 'divi' 00575 ELSE IF (INDEX(opp_str(1:leng),'^') > 0) THEN 00576 opps(nbops) = 'power' 00577 ELSE 00578 CALL histerr(ierrh,'decoop','Unknown operation',opp_str(1:leng),' ') 00579 ENDIF 00580 ENDIF 00581 !----- 00582 leng = LEN_TRIM(scal_str) 00583 ppos = INDEX(scal_str,'.') 00584 epos = INDEX(scal_str,'e') 00585 IF (epos == 0) epos = INDEX(scal_str,'E') 00586 !----- 00587 !----- Try to catch a few errors 00588 !----- 00589 IF (INDEX(ops,scal_str) > 0) THEN 00590 CALL histerr(ierrh,'decoop','Strange scalar you have here ',scal_str,pstr) 00591 ENDIF 00592 IF (epos > 0) THEN 00593 WRITE(tl,'(I3.3)') leng 00594 WRITE(dl,'(I3.3)') epos-ppos-1 00595 fmt='(e'//tl//'.'//dl//')' 00596 READ(scal_str,fmt) scal(nbops) 00597 ELSE IF (ppos > 0) THEN 00598 WRITE(tl,'(I3.3)') leng 00599 WRITE(dl,'(I3.3)') leng-ppos 00600 fmt='(f'//tl//'.'//dl//')' 00601 READ(scal_str,fmt) scal(nbops) 00602 ELSE 00603 WRITE(tl,'(I3.3)') leng 00604 fmt = '(I'//tl//')' 00605 READ(scal_str,fmt) int_tmp 00606 scal(nbops) = REAL(int_tmp,kind=ip_single_p) 00607 ENDIF 00608 ENDIF 00609 IF (check) WRITE(*,*) 'decoop : Finished interpretation' 00610 CALL findsep(str,nbsep,f_char,f_pos,s_char,s_pos) 00611 ENDDO 00612 ! 00613 !----------------------- 00614 END SUBROUTINE decoop_r8 00615 != 00616 SUBROUTINE findsep (str,nbsep,f_char,f_pos,s_char,s_pos) 00617 !--------------------------------------------------------------------- 00618 !- Subroutine finds all separators in a given string 00619 !- It returns the following information about str : 00620 !- f_char : The first separation character 00621 !- (1 for before and 2 for after) 00622 !- f_pos : The position of the first separator 00623 !- s_char : The second separation character 00624 !- (1 for before and 2 for after) 00625 !- s_pos : The position of the second separator 00626 !--------------------------------------------------------------------- 00627 USE mod_comprism_proto 00628 IMPLICIT NONE 00629 !- 00630 CHARACTER*80 :: str 00631 INTEGER (kind=ip_intwp_p) :: nbsep 00632 INTEGER (kind=ip_intwp_p) ,PARAMETER :: ierr=3 00633 CHARACTER*1 :: f_char(2),s_char(2) 00634 INTEGER (kind=ip_intwp_p) :: f_pos(2),s_pos(2) 00635 !- 00636 CHARACTER*70 :: str_tmp 00637 LOGICAL :: f_found,s_found 00638 INTEGER (kind=ip_intwp_p) ::ind,xpos,leng,i 00639 !- 00640 LOGICAL :: check = .FALSE. 00641 !--------------------------------------------------------------------- 00642 ! 00643 IF (check) & 00644 & WRITE(*,*) 'findsep : call cleanstr: ',str(1:LEN_TRIM(str)) 00645 !- 00646 CALL cleanstr(str) 00647 !- 00648 IF (check) & 00649 & WRITE(*,*) 'findsep : out of cleanstr: ',str(1:LEN_TRIM(str)) 00650 !- 00651 xpos = INDEX(str,'X') 00652 leng = LEN_TRIM(str) 00653 !- 00654 f_pos(1:2) = (/ 0,leng+1 /) 00655 f_char(1:2) = (/ '?','?' /) 00656 s_pos(1:2) = (/ 0,leng+1 /) 00657 s_char(1:2) = (/ '?','?' /) 00658 !- 00659 nbsep = 0 00660 !- 00661 f_found = .FALSE. 00662 s_found = .FALSE. 00663 IF (xpos > 1) THEN 00664 DO i=xpos-1,1,-1 00665 ind = INDEX(seps,str(i:i)) 00666 IF (ind > 0) THEN 00667 IF (.NOT.f_found) THEN 00668 f_char(1) = str(i:i) 00669 f_pos(1) = i 00670 nbsep = nbsep+1 00671 f_found = .TRUE. 00672 ELSE IF (.NOT.s_found) THEN 00673 s_char(1) = str(i:i) 00674 s_pos(1) = i 00675 nbsep = nbsep+1 00676 s_found = .TRUE. 00677 ENDIF 00678 ENDIF 00679 ENDDO 00680 ENDIF 00681 !- 00682 f_found = .FALSE. 00683 s_found = .FALSE. 00684 IF (xpos < leng) THEN 00685 DO i=xpos+1,leng 00686 ind = INDEX(seps,str(i:i)) 00687 IF (ind > 0) THEN 00688 IF (.NOT.f_found) THEN 00689 f_char(2) = str(i:i) 00690 f_pos(2) = i 00691 nbsep = nbsep+1 00692 f_found = .TRUE. 00693 ELSE IF (.NOT.s_found) THEN 00694 s_char(2) = str(i:i) 00695 s_pos(2) = i 00696 nbsep = nbsep+1 00697 s_found = .TRUE. 00698 ENDIF 00699 ENDIF 00700 ENDDO 00701 ENDIF 00702 !- 00703 IF (nbsep > 4) THEN 00704 WRITE(str_tmp,'("number :",I3)') nbsep 00705 CALL histerr(ierr,'findsep','How can I find that many separators',str_tmp,str) 00706 ENDIF 00707 !- 00708 IF (check) WRITE(*,*) 'Finished findsep : ',nbsep,leng 00709 ! 00710 !------------------------ 00711 END SUBROUTINE findsep 00712 != 00713 SUBROUTINE cleanstr(str) 00714 !--------------------------------------------------------------------- 00715 !- We clean up the string by taking out the extra () and puting 00716 !- everything in lower case except for the X describing the variable 00717 !--------------------------------------------------------------------- 00718 USE mod_comprism_proto 00719 IMPLICIT NONE 00720 !- 00721 CHARACTER*80 :: str 00722 !- 00723 INTEGER (kind=ip_intwp_p) :: ind,leng,ic,it 00724 LOGICAL :: check = .FALSE. 00725 !--------------------------------------------------------------------- 00726 ! 00727 leng = LEN_TRIM(str) 00728 CALL strlowercase(str) 00729 !- 00730 ind = INDEX(str,'x') 00731 IF (check) WRITE (*,*) 'cleanstr 1.0 : ind = ',ind,' str = ',str(1:leng),'---' 00732 !- 00733 !- If the character before the x is not a letter then we can assume that 00734 !- it is the variable and promote it to a capital letter 00735 !- 00736 DO WHILE (ind > 0) 00737 ic = 0 00738 IF (ind > 1) ic = IACHAR(str(ind-1:ind-1)) 00739 IF (ic < 97 .OR. ic > 122) THEN 00740 str(ind:ind) = 'X' 00741 ENDIF 00742 it = INDEX(str(ind+1:leng),'x') 00743 IF (it > 0) THEN 00744 ind = ind+it 00745 ELSE 00746 ind = it 00747 ENDIF 00748 ENDDO 00749 !- 00750 IF (check) WRITE (*,*) 'cleanstr 2.0 : str = ',str(1:leng),'---' 00751 !- 00752 IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN 00753 str = str(2:leng-1) 00754 ENDIF 00755 !- 00756 IF (check) WRITE (*,*) 'cleanstr 3.0 : str = ',str(1:leng),'---' 00757 !- 00758 leng = LEN_TRIM(str) 00759 ind = INDEX(str,'((X))') 00760 IF (ind > 0) THEN 00761 str=str(1:ind-1)//'(X)'//str(ind+5:leng)//' ' 00762 ENDIF 00763 !- 00764 IF (check) WRITE (*,*) 'cleanstr 4.0 : str = ',str(1:leng),'---' 00765 !- 00766 leng = LEN_TRIM(str) 00767 ind = INDEX(str,'(X)') 00768 IF (ind > 0 .AND. ind+3 < leng) THEN 00769 IF ( INDEX(seps,str(ind-1:ind-1)) > 0 .AND. INDEX(seps,str(ind+3:ind+3)) > 0) THEN 00770 str=str(1:ind-1)//'X'//str(ind+3:leng)//' ' 00771 ENDIF 00772 ENDIF 00773 !- 00774 IF (check) WRITE (*,*) 'cleanstr 5.0 : str = ',str(1:leng),'---' 00775 !- 00776 leng = LEN_TRIM(str) 00777 ind = INDEX(str(1:leng),' ') 00778 DO WHILE (ind > 0) 00779 str=str(1:ind-1)//str(ind+1:leng)//' ' 00780 leng = LEN_TRIM(str) 00781 ind = INDEX(str(1:leng),' ') 00782 ENDDO 00783 !- 00784 IF (check) WRITE (*,*) 'cleanstr 6.0 : str = ',str(1:leng),'---' 00785 ! 00786 !------------------------- 00787 END SUBROUTINE cleanstr 00788 != 00789 SUBROUTINE mathop_r114(fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out) 00790 !--------------------------------------------------------------------- 00791 !- This soubroutines gives an interface to the various operation 00792 !- which are allowed. The interface is general enough to allow its use 00793 !- for other cases. 00794 !- 00795 !- INPUT 00796 !- 00797 !- fun : function to be applied to the vector of data 00798 !- nb : Length of input vector 00799 !- work_in : Input vector of data (REAL (kind=ip_single_p)) 00800 !- miss_val : The value of the missing data flag (it has to be a 00801 !- maximum value, in f90 : huge( a real )) 00802 !- nb_index : Length of index vector 00803 !- nindex : Vector of indices 00804 !- scal : A scalar value for vector/scalar operations 00805 !- nb_max : maximum length of output vector 00806 !- 00807 !- OUTPUT 00808 !- 00809 !- nb_max : Actual length of output variable 00810 !- work_out : Output vector after the operation was applied 00811 !--------------------------------------------------------------------- 00812 USE mod_comprism_proto 00813 IMPLICIT NONE 00814 !- 00815 CHARACTER*7 :: fun 00816 INTEGER (kind=ip_intwp_p):: nb,nb_max,nb_index 00817 INTEGER (kind=ip_intwp_p) ,PARAMETER :: ierrh=3 00818 INTEGER (kind=ip_intwp_p):: nindex(nb_index) 00819 REAL (kind=ip_single_p) :: miss_val 00820 REAL (kind=ip_single_p) ::work_in(nb),scal 00821 REAL (kind=ip_single_p) ::work_out(nb_max) 00822 !- 00823 INTEGER (kind=ip_intwp_p):: ierr 00824 !- 00825 INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,ALOG,SQRT,ABS 00826 !--------------------------------------------------------------------- 00827 ! 00828 ierr = 0 00829 !- 00830 IF (scal >= miss_val-1.) THEN 00831 IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN 00832 SELECT CASE (fun) 00833 CASE('sin') 00834 ierr = ma_sin_r114(nb,work_in,nb_max,work_out) 00835 CASE('cos') 00836 ierr = ma_cos_r114(nb,work_in,nb_max,work_out) 00837 CASE('tan') 00838 ierr = ma_tan_r114(nb,work_in,nb_max,work_out) 00839 CASE('asin') 00840 ierr = ma_asin_r114(nb,work_in,nb_max,work_out) 00841 CASE('acos') 00842 ierr = ma_acos_r114(nb,work_in,nb_max,work_out) 00843 CASE('atan') 00844 ierr = ma_atan_r114(nb,work_in,nb_max,work_out) 00845 CASE('exp') 00846 ierr = ma_exp_r114(nb,work_in,nb_max,work_out) 00847 CASE('log') 00848 ierr = ma_alog_r114(nb,work_in,nb_max,work_out) 00849 CASE('sqrt') 00850 ierr = ma_sqrt_r114(nb,work_in,nb_max,work_out) 00851 CASE('chs') 00852 ierr = ma_chs_r114(nb,work_in,nb_max,work_out) 00853 CASE('abs') 00854 ierr = ma_abs_r114(nb,work_in,nb_max,work_out) 00855 CASE('cels') 00856 ierr = ma_cels_r114(nb,work_in,nb_max,work_out) 00857 CASE('kelv') 00858 ierr = ma_kelv_r114(nb,work_in,nb_max,work_out) 00859 CASE('deg') 00860 ierr = ma_deg_r114(nb,work_in,nb_max,work_out) 00861 CASE('rad') 00862 ierr = ma_rad_r114(nb,work_in,nb_max,work_out) 00863 CASE('ident') 00864 ierr = ma_ident_r114(nb,work_in,nb_max,work_out) 00865 CASE DEFAULT 00866 CALL histerr(ierrh,"mathop",'scalar variable undefined and no indexing','but still unknown function',fun) 00867 END SELECT 00868 IF (ierr > 0) THEN 00869 CALL histerr(ierrh,"mathop",'Error while executing a simple function',fun,' ') 00870 ENDIF 00871 ELSE 00872 SELECT CASE (fun) 00873 CASE('gather') 00874 ierr = ma_fugath_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 00875 CASE('scatter') 00876 IF (nb_index > nb) THEN 00877 DO ierr=1,nb_max 00878 work_out(ierr)=miss_val 00879 ENDDO 00880 ierr=1 00881 ELSE 00882 ierr = ma_fuscat_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 00883 ENDIF 00884 CASE('coll') 00885 ierr = ma_fucoll_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 00886 CASE('fill') 00887 ierr = ma_fufill_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 00888 CASE('undef') 00889 ierr = ma_fuundef_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 00890 CASE('only') 00891 ierr = ma_fuonly_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 00892 CASE DEFAULT 00893 CALL histerr(ierrh,"mathop",'scalar variable undefined and indexing',& 00894 & 'was requested but with unknown function',fun) 00895 END SELECT 00896 IF (ierr > 0) THEN 00897 CALL histerr(ierrh,"mathop_r114",'Error while executing an indexing function',fun,' ') 00898 ENDIF 00899 ENDIF 00900 ELSE 00901 SELECT CASE (fun) 00902 CASE('fumin') 00903 ierr = ma_fumin_r114(nb,work_in,scal,nb_max,work_out) 00904 CASE('fumax') 00905 ierr = ma_fumax_r114(nb,work_in,scal,nb_max,work_out) 00906 CASE('add') 00907 ierr = ma_add_r114(nb,work_in,scal,nb_max,work_out) 00908 CASE('subi') 00909 ierr = ma_subi_r114(nb,work_in,scal,nb_max,work_out) 00910 CASE('sub') 00911 ierr = ma_sub_r114(nb,work_in,scal,nb_max,work_out) 00912 CASE('mult') 00913 ierr = ma_mult_r114(nb,work_in,scal,nb_max,work_out) 00914 CASE('div') 00915 ierr = ma_div_r114(nb,work_in,scal,nb_max,work_out) 00916 CASE('divi') 00917 ierr = ma_divi_r114(nb,work_in,scal,nb_max,work_out) 00918 CASE('power') 00919 ierr = ma_power_r114(nb,work_in,scal,nb_max,work_out) 00920 CASE DEFAULT 00921 CALL histerr(ierrh,"mathop",'Unknown operation with a scalar',fun,' ') 00922 END SELECT 00923 IF (ierr > 0) THEN 00924 CALL histerr(ierrh,"mathop",'Error while executing a scalar function',fun,' ') 00925 ENDIF 00926 ENDIF 00927 ! 00928 !--------------------------- 00929 END SUBROUTINE mathop_r114 00930 ! 00931 !- INCLUDE 'mafunc_r11.inc' 00932 !------------------------------------------------------ 00933 !------------------------------------------------------ 00934 ! FUNCTIONS (only one argument) 00935 !------------------------------------------------------ 00936 !------------------------------------------------------ 00937 FUNCTION ma_sin_r114(nb,x,nbo,y) 00938 USE mod_kinds_model 00939 IMPLICIT NONE 00940 INTEGER (kind=ip_intwp_p) :: ma_sin_r114 00941 INTEGER (kind=ip_intwp_p) :: nb,nbo,i 00942 REAL (kind=ip_single_p) ::x(nb),y(nbo) 00943 00944 DO i=1,nb 00945 y(i) = SIN(x(i)) 00946 ENDDO 00947 00948 nbo = nb 00949 ma_sin_r114 = 0 00950 00951 END FUNCTION ma_sin_r114 00952 !------------------------------------------------------ 00953 !------------------------------------------------------ 00954 !------------------------------------------------------ 00955 FUNCTION ma_cos_r114(nb,x,nbo,y) 00956 USE mod_kinds_model 00957 IMPLICIT NONE 00958 INTEGER (kind=ip_intwp_p) :: ma_cos_r114 00959 INTEGER (kind=ip_intwp_p):: nb,nbo,i 00960 REAL (kind=ip_single_p) ::x(nb),y(nbo) 00961 00962 DO i=1,nb 00963 y(i) = COS(x(i)) 00964 ENDDO 00965 00966 nbo = nb 00967 ma_cos_r114 = 0 00968 00969 END FUNCTION ma_cos_r114 00970 !------------------------------------------------------ 00971 !------------------------------------------------------ 00972 !------------------------------------------------------ 00973 FUNCTION ma_tan_r114(nb,x,nbo,y) 00974 USE mod_kinds_model 00975 IMPLICIT NONE 00976 INTEGER (kind=ip_intwp_p) :: ma_tan_r114 00977 00978 INTEGER (kind=ip_intwp_p):: nb,nbo,i 00979 REAL (kind=ip_single_p) ::x(nb),y(nbo) 00980 00981 DO i=1,nb 00982 y(i) = TAN(x(i)) 00983 ENDDO 00984 00985 nbo = nb 00986 ma_tan_r114 = 0 00987 00988 END FUNCTION ma_tan_r114 00989 !------------------------------------------------------ 00990 !------------------------------------------------------ 00991 !------------------------------------------------------ 00992 FUNCTION ma_asin_r114(nb,x,nbo,y) 00993 USE mod_kinds_model 00994 IMPLICIT NONE 00995 INTEGER (kind=ip_intwp_p) ma_asin_r114 00996 INTEGER (kind=ip_intwp_p):: nb,nbo,i 00997 REAL (kind=ip_single_p) ::x(nb),y(nbo) 00998 00999 DO i=1,nb 01000 y(i) = ASIN(x(i)) 01001 ENDDO 01002 01003 nbo = nb 01004 ma_asin_r114 = 0 01005 01006 END FUNCTION ma_asin_r114 01007 !------------------------------------------------------ 01008 !------------------------------------------------------ 01009 !------------------------------------------------------ 01010 FUNCTION ma_acos_r114(nb,x,nbo,y) 01011 USE mod_kinds_model 01012 IMPLICIT NONE 01013 INTEGER (kind=ip_intwp_p):: ma_acos_r114 01014 INTEGER (kind=ip_intwp_p):: nb,nbo,i 01015 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01016 01017 DO i=1,nb 01018 y(i) = ACOS(x(i)) 01019 ENDDO 01020 01021 nbo = nb 01022 ma_acos_r114 = 0 01023 01024 END FUNCTION ma_acos_r114 01025 !------------------------------------------------------ 01026 !------------------------------------------------------ 01027 !------------------------------------------------------ 01028 FUNCTION ma_atan_r114(nb,x,nbo,y) 01029 USE mod_kinds_model 01030 IMPLICIT NONE 01031 INTEGER (kind=ip_intwp_p) :: ma_atan_r114 01032 INTEGER (kind=ip_intwp_p):: nb,nbo,i 01033 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01034 01035 DO i=1,nb 01036 y(i) = ATAN(x(i)) 01037 ENDDO 01038 01039 nbo = nb 01040 ma_atan_r114 = 0 01041 01042 END FUNCTION ma_atan_r114 01043 !------------------------------------------------------ 01044 !------------------------------------------------------ 01045 !------------------------------------------------------ 01046 FUNCTION ma_exp_r114(nb,x,nbo,y) 01047 USE mod_kinds_model 01048 IMPLICIT NONE 01049 INTEGER (kind=ip_intwp_p):: ma_exp_r114 01050 INTEGER (kind=ip_intwp_p):: nb,nbo,i 01051 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01052 01053 DO i=1,nb 01054 y(i) = EXP(x(i)) 01055 ENDDO 01056 01057 nbo = nb 01058 ma_exp_r114 = 0 01059 01060 END FUNCTION ma_exp_r114 01061 !------------------------------------------------------ 01062 !------------------------------------------------------ 01063 !------------------------------------------------------ 01064 FUNCTION ma_alog_r114(nb,x,nbo,y) 01065 USE mod_kinds_model 01066 IMPLICIT NONE 01067 INTEGER (kind=ip_intwp_p):: ma_alog_r114 01068 INTEGER (kind=ip_intwp_p):: nb,nbo,i 01069 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01070 01071 DO i=1,nb 01072 y(i) = log(x(i)) 01073 ENDDO 01074 01075 nbo = nb 01076 ma_alog_r114 = 0 01077 01078 END FUNCTION ma_alog_r114 01079 !------------------------------------------------------ 01080 !------------------------------------------------------ 01081 !------------------------------------------------------ 01082 FUNCTION ma_sqrt_r114(nb,x,nbo,y) 01083 USE mod_kinds_model 01084 IMPLICIT NONE 01085 INTEGER (kind=ip_intwp_p):: ma_sqrt_r114 01086 INTEGER (kind=ip_intwp_p):: nb,nbo,i 01087 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01088 01089 DO i=1,nb 01090 y(i) = SQRT(x(i)) 01091 ENDDO 01092 01093 nbo = nb 01094 ma_sqrt_r114 = 0 01095 01096 END FUNCTION ma_sqrt_r114 01097 !------------------------------------------------------ 01098 !------------------------------------------------------ 01099 !------------------------------------------------------ 01100 FUNCTION ma_abs_r114(nb,x,nbo,y) 01101 USE mod_kinds_model 01102 IMPLICIT NONE 01103 INTEGER (kind=ip_intwp_p):: ma_abs_r114 01104 INTEGER (kind=ip_intwp_p):: nb,nbo,i 01105 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01106 01107 DO i=1,nb 01108 y(i) = ABS(x(i)) 01109 ENDDO 01110 01111 nbo = nb 01112 ma_abs_r114 = 0 01113 01114 END FUNCTION ma_abs_r114 01115 !------------------------------------------------------ 01116 !------------------------------------------------------ 01117 !------------------------------------------------------ 01118 FUNCTION ma_chs_r114(nb,x,nbo,y) 01119 USE mod_kinds_model 01120 IMPLICIT NONE 01121 INTEGER (kind=ip_intwp_p):: ma_chs_r114 01122 INTEGER (kind=ip_intwp_p):: nb,nbo,i 01123 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01124 01125 DO i=1,nb 01126 y(i) = x(i)*(-1.) 01127 ENDDO 01128 01129 nbo = nb 01130 ma_chs_r114 = 0 01131 01132 END FUNCTION ma_chs_r114 01133 !------------------------------------------------------ 01134 !------------------------------------------------------ 01135 !------------------------------------------------------ 01136 FUNCTION ma_cels_r114(nb,x,nbo,y) 01137 USE mod_kinds_model 01138 01139 IMPLICIT NONE 01140 01141 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_cels_r114 01142 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01143 01144 DO i=1,nb 01145 y(i) = x(i)-273.15 01146 ENDDO 01147 01148 nbo = nb 01149 ma_cels_r114 = 0 01150 01151 01152 END FUNCTION ma_cels_r114 01153 !------------------------------------------------------ 01154 !------------------------------------------------------ 01155 !------------------------------------------------------ 01156 FUNCTION ma_kelv_r114(nb,x,nbo,y) 01157 USE mod_kinds_model 01158 01159 IMPLICIT NONE 01160 01161 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_kelv_r114 01162 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01163 01164 DO i=1,nb 01165 y(i) = x(i)+273.15 01166 ENDDO 01167 01168 nbo = nb 01169 ma_kelv_r114 = 0 01170 01171 END FUNCTION ma_kelv_r114 01172 !------------------------------------------------------ 01173 !------------------------------------------------------ 01174 !------------------------------------------------------ 01175 FUNCTION ma_deg_r114(nb,x,nbo,y) 01176 USE mod_kinds_model 01177 01178 IMPLICIT NONE 01179 01180 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_deg_r114 01181 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01182 DO i=1,nb 01183 y(i) = x(i)*57.29577951 01184 ENDDO 01185 01186 nbo = nb 01187 ma_deg_r114 = 0 01188 01189 END FUNCTION ma_deg_r114 01190 !------------------------------------------------------ 01191 !------------------------------------------------------ 01192 !------------------------------------------------------ 01193 FUNCTION ma_rad_r114(nb,x,nbo,y) 01194 USE mod_kinds_model 01195 01196 IMPLICIT NONE 01197 01198 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_rad_r114 01199 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01200 01201 DO i=1,nb 01202 y(i) = x(i)*0.01745329252 01203 ENDDO 01204 01205 nbo = nb 01206 ma_rad_r114 = 0 01207 01208 END FUNCTION ma_rad_r114 01209 !------------------------------------------------------ 01210 !------------------------------------------------------ 01211 !------------------------------------------------------ 01212 FUNCTION ma_ident_r114(nb,x,nbo,y) 01213 USE mod_kinds_model 01214 01215 IMPLICIT NONE 01216 01217 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_ident_r114 01218 REAL (kind=ip_single_p) ::x(nb),y(nbo) 01219 01220 DO i=1,nb 01221 y(i) = x(i) 01222 ENDDO 01223 01224 nbo = nb 01225 ma_ident_r114 = 0 01226 01227 END FUNCTION ma_ident_r114 01228 !------------------------------------------------------ 01229 !------------------------------------------------------ 01230 ! OPERATIONS (two argument) 01231 !------------------------------------------------------ 01232 !------------------------------------------------------ 01233 FUNCTION ma_add_r114(nb,x,s,nbo,y) 01234 USE mod_kinds_model 01235 01236 IMPLICIT NONE 01237 01238 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_add_r114 01239 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01240 01241 INTEGER (kind=ip_intwp_p):: i 01242 01243 DO i = 1,nb 01244 y(i) = x(i)+s 01245 ENDDO 01246 01247 nbo = nb 01248 ma_add_r114 = 0 01249 01250 END FUNCTION ma_add_r114 01251 !------------------------------------------------------ 01252 !------------------------------------------------------ 01253 !------------------------------------------------------ 01254 FUNCTION ma_sub_r114(nb,x,s,nbo,y) 01255 USE mod_kinds_model 01256 01257 IMPLICIT NONE 01258 01259 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_sub_r114 01260 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01261 01262 INTEGER (kind=ip_intwp_p):: i 01263 01264 DO i = 1,nb 01265 y(i) = x(i)-s 01266 ENDDO 01267 01268 nbo = nb 01269 ma_sub_r114 = 0 01270 01271 END FUNCTION ma_sub_r114 01272 !------------------------------------------------------ 01273 !------------------------------------------------------ 01274 !------------------------------------------------------ 01275 FUNCTION ma_subi_r114(nb,x,s,nbo,y) 01276 USE mod_kinds_model 01277 01278 IMPLICIT NONE 01279 01280 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_subi_r114 01281 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01282 01283 INTEGER (kind=ip_intwp_p):: i 01284 01285 DO i = 1,nb 01286 y(i) = s-x(i) 01287 ENDDO 01288 01289 nbo = nb 01290 ma_subi_r114 = 0 01291 01292 END FUNCTION ma_subi_r114 01293 !------------------------------------------------------ 01294 !------------------------------------------------------ 01295 !------------------------------------------------------ 01296 FUNCTION ma_mult_r114(nb,x,s,nbo,y) 01297 USE mod_kinds_model 01298 01299 IMPLICIT NONE 01300 01301 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_mult_r114 01302 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01303 01304 INTEGER (kind=ip_intwp_p):: i 01305 01306 DO i = 1,nb 01307 y(i) = x(i)*s 01308 ENDDO 01309 01310 nbo = nb 01311 ma_mult_r114 = 0 01312 01313 END FUNCTION ma_mult_r114 01314 !------------------------------------------------------ 01315 !------------------------------------------------------ 01316 !------------------------------------------------------ 01317 FUNCTION ma_div_r114(nb,x,s,nbo,y) 01318 USE mod_kinds_model 01319 01320 IMPLICIT NONE 01321 01322 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_div_r114 01323 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01324 01325 INTEGER (kind=ip_intwp_p):: i 01326 01327 DO i = 1,nb 01328 y(i) = x(i)/s 01329 ENDDO 01330 01331 nbo = nb 01332 ma_div_r114 = 0 01333 01334 END FUNCTION ma_div_r114 01335 !------------------------------------------------------ 01336 !------------------------------------------------------ 01337 !------------------------------------------------------ 01338 FUNCTION ma_divi_r114(nb,x,s,nbo,y) 01339 USE mod_kinds_model 01340 01341 IMPLICIT NONE 01342 01343 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_divi_r114 01344 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01345 01346 INTEGER (kind=ip_intwp_p):: i 01347 01348 DO i = 1,nb 01349 y(i) = s/x(i) 01350 ENDDO 01351 01352 nbo = nb 01353 ma_divi_r114 = 0 01354 01355 END FUNCTION ma_divi_r114 01356 !------------------------------------------------------ 01357 !------------------------------------------------------ 01358 !------------------------------------------------------ 01359 FUNCTION ma_power_r114(nb,x,s,nbo,y) 01360 USE mod_kinds_model 01361 01362 IMPLICIT NONE 01363 01364 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_power_r114 01365 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01366 01367 INTEGER (kind=ip_intwp_p):: i 01368 01369 DO i = 1,nb 01370 y(i) = x(i) ** s 01371 ENDDO 01372 01373 nbo = nb 01374 ma_power_r114 = 0 01375 01376 END FUNCTION ma_power_r114 01377 !------------------------------------------------------ 01378 !------------------------------------------------------ 01379 !------------------------------------------------------ 01380 FUNCTION ma_fumin_r114(nb,x,s,nbo,y) 01381 USE mod_kinds_model 01382 01383 IMPLICIT NONE 01384 01385 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_fumin_r114 01386 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01387 01388 INTEGER (kind=ip_intwp_p):: i 01389 01390 DO i = 1,nb 01391 y(i) = min(x(i),s) 01392 ENDDO 01393 01394 nbo = nb 01395 ma_fumin_r114 = 0 01396 01397 END FUNCTION ma_fumin_r114 01398 !------------------------------------------------------ 01399 !------------------------------------------------------ 01400 !------------------------------------------------------ 01401 FUNCTION ma_fumax_r114(nb,x,s,nbo,y) 01402 USE mod_kinds_model 01403 01404 IMPLICIT NONE 01405 01406 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_fumax_r114 01407 REAL (kind=ip_single_p) ::x(nb),s,y(nbo) 01408 01409 INTEGER (kind=ip_intwp_p):: i 01410 01411 DO i = 1,nb 01412 y(i) = max(x(i),s) 01413 ENDDO 01414 01415 nbo = nb 01416 ma_fumax_r114 = 0 01417 01418 END FUNCTION ma_fumax_r114 01419 !------------------------------------------------------ 01420 !------------------------------------------------------ 01421 !------------------------------------------------------ 01422 FUNCTION ma_fuscat_r114(nb,x,nbi,ind,miss_val,nbo,y) 01423 USE mod_kinds_model 01424 01425 IMPLICIT NONE 01426 01427 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuscat_r114 01428 INTEGER (kind=ip_intwp_p):: ind(nbi) 01429 REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo) 01430 01431 INTEGER (kind=ip_intwp_p):: i,ii,ipos 01432 01433 ma_fuscat_r114 = 0 01434 01435 DO i = 1,nbo 01436 y(i) = miss_val 01437 ENDDO 01438 01439 IF (nbi <= nb) THEN 01440 01441 ipos = 0 01442 DO i = 1,nbi 01443 IF (ind(i) <= nbo .AND. ind(i) > 0) THEN 01444 ipos = ipos+1 01445 y(ind(i)) = x(ipos) 01446 ELSE 01447 IF (ind(i) > nbo) ma_fuscat_r114 = ma_fuscat_r114+1 01448 ENDIF 01449 ENDDO 01450 ! 01451 ! Repeate the data if needed 01452 ! 01453 IF (MINVAL(ind) < 0) THEN 01454 DO i = 1,nbi 01455 IF (ind(i) <= 0) THEN 01456 DO ii=1,ABS(ind(i))-1 01457 IF (ind(i+1)+ii <= nbo) THEN 01458 y(ind(i+1)+ii) = y(ind(i+1)) 01459 ELSE 01460 ma_fuscat_r114 = ma_fuscat_r114+1 01461 ENDIF 01462 ENDDO 01463 ENDIF 01464 ENDDO 01465 ENDIF 01466 ! 01467 ELSE 01468 01469 ma_fuscat_r114 = 1 01470 01471 ENDIF 01472 01473 END FUNCTION ma_fuscat_r114 01474 !------------------------------------------------------ 01475 !------------------------------------------------------ 01476 !------------------------------------------------------ 01477 FUNCTION ma_fugath_r114(nb,x,nbi,ind,miss_val,nbo,y) 01478 USE mod_kinds_model 01479 01480 IMPLICIT NONE 01481 01482 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fugath_r114 01483 INTEGER (kind=ip_intwp_p):: ind(nbi) 01484 REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo) 01485 01486 INTEGER (kind=ip_intwp_p):: i,ipos 01487 01488 IF (nbi <= nbo) THEN 01489 01490 ma_fugath_r114 = 0 01491 01492 DO i=1,nbo 01493 y(i) = miss_val 01494 ENDDO 01495 01496 ipos = 0 01497 DO i = 1,nbi 01498 IF (ipos+1 <= nbo) THEN 01499 IF (ind(i) > 0) THEN 01500 ipos = ipos+1 01501 y(ipos) = x(ind(i)) 01502 ENDIF 01503 ELSE 01504 IF (ipos+1 > nbo) ma_fugath_r114 = ma_fugath_r114+1 01505 ENDIF 01506 ENDDO 01507 01508 ELSE 01509 01510 ma_fugath_r114 = 1 01511 01512 ENDIF 01513 01514 nbo = ipos 01515 01516 END FUNCTION ma_fugath_r114 01517 !------------------------------------------------------ 01518 !------------------------------------------------------ 01519 !------------------------------------------------------ 01520 FUNCTION ma_fufill_r114(nb,x,nbi,ind,miss_val,nbo,y) 01521 USE mod_kinds_model 01522 01523 IMPLICIT NONE 01524 01525 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fufill_r114 01526 INTEGER (kind=ip_intwp_p):: ind(nbi) 01527 REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo) 01528 01529 INTEGER (kind=ip_intwp_p):: i,ii,ipos 01530 01531 ma_fufill_r114 = 0 01532 01533 IF (nbi <= nb) THEN 01534 01535 ipos = 0 01536 DO i = 1,nbi 01537 IF (ind(i) <= nbo .AND. ind(i) > 0) THEN 01538 ipos = ipos+1 01539 y(ind(i)) = x(ipos) 01540 ELSE 01541 IF (ind(i) > nbo) ma_fufill_r114 = ma_fufill_r114+1 01542 ENDIF 01543 ENDDO 01544 ! 01545 ! Repeate the data if needed 01546 ! 01547 IF (MINVAL(ind) < 0) THEN 01548 DO i = 1,nbi 01549 IF (ind(i) <= 0) THEN 01550 DO ii=1,ABS(ind(i))-1 01551 IF (ind(i+1)+ii <= nbo) THEN 01552 y(ind(i+1)+ii) = y(ind(i+1)) 01553 ELSE 01554 ma_fufill_r114 = ma_fufill_r114+1 01555 ENDIF 01556 ENDDO 01557 ENDIF 01558 ENDDO 01559 ENDIF 01560 01561 ELSE 01562 01563 ma_fufill_r114 = 1 01564 01565 ENDIF 01566 01567 END FUNCTION ma_fufill_r114 01568 !------------------------------------------------------ 01569 !------------------------------------------------------ 01570 !------------------------------------------------------ 01571 FUNCTION ma_fucoll_r114(nb,x,nbi,ind,miss_val,nbo,y) 01572 USE mod_kinds_model 01573 01574 IMPLICIT NONE 01575 01576 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fucoll_r114 01577 INTEGER (kind=ip_intwp_p):: ind(nbi) 01578 REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo) 01579 01580 INTEGER (kind=ip_intwp_p):: i,ipos 01581 01582 IF (nbi <= nbo) THEN 01583 01584 ma_fucoll_r114 = 0 01585 01586 ipos = 0 01587 DO i = 1,nbi 01588 ! 01589 IF (ipos+1 <= nbo) THEN 01590 IF (ind(i) > 0) THEN 01591 ipos = ipos+1 01592 y(ipos) = x(ind(i)) 01593 ENDIF 01594 ELSE 01595 IF (ipos+1 > nbo) ma_fucoll_r114 = ma_fucoll_r114+1 01596 ENDIF 01597 ENDDO 01598 ! 01599 ELSE 01600 ! 01601 ma_fucoll_r114 = 1 01602 ! 01603 ENDIF 01604 01605 nbo = ipos 01606 01607 END FUNCTION ma_fucoll_r114 01608 !------------------------------------------------------ 01609 !------------------------------------------------------ 01610 !------------------------------------------------------ 01611 !------------------------------------------------------ 01612 FUNCTION ma_fuundef_r114(nb,x,nbi,ind,miss_val,nbo,y) 01613 USE mod_kinds_model 01614 01615 IMPLICIT NONE 01616 01617 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuundef_r114 01618 INTEGER (kind=ip_intwp_p):: ind(nbi) 01619 REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo) 01620 01621 INTEGER (kind=ip_intwp_p):: i 01622 01623 IF (nbi <= nbo .AND. nbo == nb) THEN 01624 01625 ma_fuundef_r114 = 0 01626 01627 DO i=1,nbo 01628 y(i) = x(i) 01629 ENDDO 01630 01631 DO i = 1,nbi 01632 IF (ind(i) <= nbo .AND. ind(i) > 0) THEN 01633 y(ind(i)) = miss_val 01634 ELSE 01635 IF (ind(i) > nbo) ma_fuundef_r114 = ma_fuundef_r114+1 01636 ENDIF 01637 ENDDO 01638 01639 ELSE 01640 01641 ma_fuundef_r114 = 1 01642 01643 ENDIF 01644 01645 END FUNCTION ma_fuundef_r114 01646 !------------------------------------------------------ 01647 !------------------------------------------------------ 01648 !------------------------------------------------------ 01649 FUNCTION ma_fuonly_r114(nb,x,nbi,ind,miss_val,nbo,y) 01650 USE mod_kinds_model 01651 01652 IMPLICIT NONE 01653 01654 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuonly_r114 01655 INTEGER (kind=ip_intwp_p):: ind(nbi) 01656 REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo) 01657 01658 INTEGER (kind=ip_intwp_p):: i 01659 01660 IF (nbi <= nbo .AND. nbo == nb) THEN 01661 01662 ma_fuonly_r114 = 0 01663 01664 DO i=1,nbo 01665 y(i) = miss_val 01666 ENDDO 01667 01668 DO i = 1,nbi 01669 IF (ind(i) <= nbo .AND. ind(i) > 0) THEN 01670 y(ind(i)) = x(ind(i)) 01671 ELSE 01672 IF (ind(i) > nbo) ma_fuonly_r114 = ma_fuonly_r114+1 01673 ENDIF 01674 ENDDO 01675 01676 ELSE 01677 01678 ma_fuonly_r114 = 1 01679 01680 ENDIF 01681 01682 END FUNCTION ma_fuonly_r114 01683 != 01684 SUBROUTINE mathop_r118(fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out) 01685 !--------------------------------------------------------------------- 01686 !- This soubroutines gives an interface to the various operation 01687 !- which are allowed. The interface is general enough to allow its use 01688 !- for other cases. 01689 !- 01690 !- INPUT 01691 !- 01692 !- fun : function to be applied to the vector of data 01693 !- nb : Length of input vector 01694 !- work_in : Input vector of data (REAL (kind=ip_double_p)) 01695 !- miss_val : The value of the missing data flag (it has to be a 01696 !- maximum value, in f90 : huge( a real )) 01697 !- nb_index : Length of index vector 01698 !- nindex : Vector of indices 01699 !- scal : A scalar value for vector/scalar operations 01700 !- nb_max : maximum length of output vector 01701 !- 01702 !- OUTPUT 01703 !- 01704 !- nb_max : Actual length of output variable 01705 !- work_out : Output vector after the operation was applied 01706 !--------------------------------------------------------------------- 01707 USE mod_comprism_proto 01708 IMPLICIT NONE 01709 !- 01710 CHARACTER*7 :: fun 01711 INTEGER (kind=ip_intwp_p):: nb,nb_max,nb_index 01712 INTEGER (kind=ip_intwp_p) ,PARAMETER :: ierrh=3 01713 INTEGER (kind=ip_intwp_p):: nindex(nb_index) 01714 REAL (kind=ip_double_p) :: miss_val 01715 REAL (kind=ip_double_p) ::work_in(nb),scal 01716 REAL (kind=ip_double_p) ::work_out(nb_max) 01717 !- 01718 INTEGER (kind=ip_intwp_p):: ierr 01719 !- 01720 INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,ALOG,SQRT,ABS 01721 !--------------------------------------------------------------------- 01722 ! 01723 ierr = 0 01724 !- 01725 IF (scal >= miss_val-1.) THEN 01726 IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN 01727 SELECT CASE (fun) 01728 CASE('sin') 01729 ierr = ma_sin_r118(nb,work_in,nb_max,work_out) 01730 CASE('cos') 01731 ierr = ma_cos_r118(nb,work_in,nb_max,work_out) 01732 CASE('tan') 01733 ierr = ma_tan_r118(nb,work_in,nb_max,work_out) 01734 CASE('asin') 01735 ierr = ma_asin_r118(nb,work_in,nb_max,work_out) 01736 CASE('acos') 01737 ierr = ma_acos_r118(nb,work_in,nb_max,work_out) 01738 CASE('atan') 01739 ierr = ma_atan_r118(nb,work_in,nb_max,work_out) 01740 CASE('exp') 01741 ierr = ma_exp_r118(nb,work_in,nb_max,work_out) 01742 CASE('log') 01743 ierr = ma_alog_r118(nb,work_in,nb_max,work_out) 01744 CASE('sqrt') 01745 ierr = ma_sqrt_r118(nb,work_in,nb_max,work_out) 01746 CASE('chs') 01747 ierr = ma_chs_r118(nb,work_in,nb_max,work_out) 01748 CASE('abs') 01749 ierr = ma_abs_r118(nb,work_in,nb_max,work_out) 01750 CASE('cels') 01751 ierr = ma_cels_r118(nb,work_in,nb_max,work_out) 01752 CASE('kelv') 01753 ierr = ma_kelv_r118(nb,work_in,nb_max,work_out) 01754 CASE('deg') 01755 ierr = ma_deg_r118(nb,work_in,nb_max,work_out) 01756 CASE('rad') 01757 ierr = ma_rad_r118(nb,work_in,nb_max,work_out) 01758 CASE('ident') 01759 ierr = ma_ident_r118(nb,work_in,nb_max,work_out) 01760 CASE DEFAULT 01761 CALL histerr(ierrh,"mathop",'scalar variable undefined and no indexing','but still unknown function',fun) 01762 END SELECT 01763 IF (ierr > 0) THEN 01764 CALL histerr(ierrh,"mathop",'Error while executing a simple function',fun,' ') 01765 ENDIF 01766 ELSE 01767 SELECT CASE (fun) 01768 CASE('gather') 01769 ierr = ma_fugath_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 01770 CASE('scatter') 01771 IF (nb_index > nb) THEN 01772 DO ierr=1,nb_max 01773 work_out(ierr)=miss_val 01774 ENDDO 01775 ierr=1 01776 ELSE 01777 ierr = ma_fuscat_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 01778 ENDIF 01779 CASE('coll') 01780 ierr = ma_fucoll_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 01781 CASE('fill') 01782 ierr = ma_fufill_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 01783 CASE('undef') 01784 ierr = ma_fuundef_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 01785 CASE('only') 01786 ierr = ma_fuonly_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out) 01787 CASE DEFAULT 01788 CALL histerr(ierrh,"mathop",'scalar variable undefined and indexing',& 01789 & 'was requested but with unknown function',fun) 01790 END SELECT 01791 IF (ierr > 0) THEN 01792 CALL histerr(ierrh,"mathop_r118",'Error while executing an indexing function',fun,' ') 01793 ENDIF 01794 ENDIF 01795 ELSE 01796 SELECT CASE (fun) 01797 CASE('fumin') 01798 ierr = ma_fumin_r118(nb,work_in,scal,nb_max,work_out) 01799 CASE('fumax') 01800 ierr = ma_fumax_r118(nb,work_in,scal,nb_max,work_out) 01801 CASE('add') 01802 ierr = ma_add_r118(nb,work_in,scal,nb_max,work_out) 01803 CASE('subi') 01804 ierr = ma_subi_r118(nb,work_in,scal,nb_max,work_out) 01805 CASE('sub') 01806 ierr = ma_sub_r118(nb,work_in,scal,nb_max,work_out) 01807 CASE('mult') 01808 ierr = ma_mult_r118(nb,work_in,scal,nb_max,work_out) 01809 CASE('div') 01810 ierr = ma_div_r118(nb,work_in,scal,nb_max,work_out) 01811 CASE('divi') 01812 ierr = ma_divi_r118(nb,work_in,scal,nb_max,work_out) 01813 CASE('power') 01814 ierr = ma_power_r118(nb,work_in,scal,nb_max,work_out) 01815 CASE DEFAULT 01816 CALL histerr(ierrh,"mathop",'Unknown operation with a scalar',fun,' ') 01817 END SELECT 01818 IF (ierr > 0) THEN 01819 CALL histerr(ierrh,"mathop",'Error while executing a scalar function',fun,' ') 01820 ENDIF 01821 ENDIF 01822 ! 01823 !--------------------------- 01824 END SUBROUTINE mathop_r118 01825 ! 01826 !- INCLUDE 'mafunc_r11.inc' 01827 !------------------------------------------------------ 01828 !------------------------------------------------------ 01829 ! FUNCTIONS (only one argument) 01830 !------------------------------------------------------ 01831 !------------------------------------------------------ 01832 FUNCTION ma_sin_r118(nb,x,nbo,y) 01833 USE mod_kinds_model 01834 01835 IMPLICIT NONE 01836 01837 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_sin_r118 01838 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01839 01840 DO i=1,nb 01841 y(i) = SIN(x(i)) 01842 ENDDO 01843 01844 nbo = nb 01845 ma_sin_r118 = 0 01846 01847 END FUNCTION ma_sin_r118 01848 !------------------------------------------------------ 01849 !------------------------------------------------------ 01850 !------------------------------------------------------ 01851 FUNCTION ma_cos_r118(nb,x,nbo,y) 01852 USE mod_kinds_model 01853 01854 IMPLICIT NONE 01855 01856 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_cos_r118 01857 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01858 01859 DO i=1,nb 01860 y(i) = COS(x(i)) 01861 ENDDO 01862 01863 nbo = nb 01864 ma_cos_r118 = 0 01865 01866 END FUNCTION ma_cos_r118 01867 !------------------------------------------------------ 01868 !------------------------------------------------------ 01869 !------------------------------------------------------ 01870 FUNCTION ma_tan_r118(nb,x,nbo,y) 01871 USE mod_kinds_model 01872 01873 IMPLICIT NONE 01874 01875 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_tan_r118 01876 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01877 01878 DO i=1,nb 01879 y(i) = TAN(x(i)) 01880 ENDDO 01881 01882 nbo = nb 01883 ma_tan_r118 = 0 01884 01885 END FUNCTION ma_tan_r118 01886 !------------------------------------------------------ 01887 !------------------------------------------------------ 01888 !------------------------------------------------------ 01889 FUNCTION ma_asin_r118(nb,x,nbo,y) 01890 USE mod_kinds_model 01891 01892 IMPLICIT NONE 01893 01894 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_asin_r118 01895 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01896 01897 DO i=1,nb 01898 y(i) = ASIN(x(i)) 01899 ENDDO 01900 01901 nbo = nb 01902 ma_asin_r118 = 0 01903 01904 END FUNCTION ma_asin_r118 01905 !------------------------------------------------------ 01906 !------------------------------------------------------ 01907 !------------------------------------------------------ 01908 FUNCTION ma_acos_r118(nb,x,nbo,y) 01909 USE mod_kinds_model 01910 01911 IMPLICIT NONE 01912 01913 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_acos_r118 01914 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01915 01916 DO i=1,nb 01917 y(i) = ACOS(x(i)) 01918 ENDDO 01919 01920 nbo = nb 01921 ma_acos_r118 = 0 01922 01923 END FUNCTION ma_acos_r118 01924 !------------------------------------------------------ 01925 !------------------------------------------------------ 01926 !------------------------------------------------------ 01927 FUNCTION ma_atan_r118(nb,x,nbo,y) 01928 USE mod_kinds_model 01929 01930 IMPLICIT NONE 01931 01932 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_atan_r118 01933 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01934 01935 DO i=1,nb 01936 y(i) = ATAN(x(i)) 01937 ENDDO 01938 01939 nbo = nb 01940 ma_atan_r118 = 0 01941 01942 END FUNCTION ma_atan_r118 01943 !------------------------------------------------------ 01944 !------------------------------------------------------ 01945 !------------------------------------------------------ 01946 FUNCTION ma_exp_r118(nb,x,nbo,y) 01947 USE mod_kinds_model 01948 01949 IMPLICIT NONE 01950 01951 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_exp_r118 01952 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01953 01954 DO i=1,nb 01955 y(i) = EXP(x(i)) 01956 ENDDO 01957 01958 nbo = nb 01959 ma_exp_r118 = 0 01960 01961 END FUNCTION ma_exp_r118 01962 !------------------------------------------------------ 01963 !------------------------------------------------------ 01964 !------------------------------------------------------ 01965 FUNCTION ma_alog_r118(nb,x,nbo,y) 01966 USE mod_kinds_model 01967 01968 IMPLICIT NONE 01969 01970 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_alog_r118 01971 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01972 01973 DO i=1,nb 01974 y(i) = log(x(i)) 01975 ENDDO 01976 01977 nbo = nb 01978 ma_alog_r118 = 0 01979 01980 END FUNCTION ma_alog_r118 01981 !------------------------------------------------------ 01982 !------------------------------------------------------ 01983 !------------------------------------------------------ 01984 FUNCTION ma_sqrt_r118(nb,x,nbo,y) 01985 USE mod_kinds_model 01986 01987 IMPLICIT NONE 01988 01989 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_sqrt_r118 01990 REAL (kind=ip_double_p) ::x(nb),y(nbo) 01991 01992 DO i=1,nb 01993 y(i) = SQRT(x(i)) 01994 ENDDO 01995 01996 nbo = nb 01997 ma_sqrt_r118 = 0 01998 01999 END FUNCTION ma_sqrt_r118 02000 !------------------------------------------------------ 02001 !------------------------------------------------------ 02002 !------------------------------------------------------ 02003 FUNCTION ma_abs_r118(nb,x,nbo,y) 02004 USE mod_kinds_model 02005 02006 IMPLICIT NONE 02007 02008 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_abs_r118 02009 REAL (kind=ip_double_p) ::x(nb),y(nbo) 02010 02011 DO i=1,nb 02012 y(i) = ABS(x(i)) 02013 ENDDO 02014 02015 nbo = nb 02016 ma_abs_r118 = 0 02017 02018 END FUNCTION ma_abs_r118 02019 !------------------------------------------------------ 02020 !------------------------------------------------------ 02021 !------------------------------------------------------ 02022 FUNCTION ma_chs_r118(nb,x,nbo,y) 02023 USE mod_kinds_model 02024 02025 IMPLICIT NONE 02026 02027 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_chs_r118 02028 REAL (kind=ip_double_p) ::x(nb),y(nbo) 02029 02030 DO i=1,nb 02031 y(i) = x(i)*(-1.) 02032 ENDDO 02033 02034 nbo = nb 02035 ma_chs_r118 = 0 02036 02037 END FUNCTION ma_chs_r118 02038 !------------------------------------------------------ 02039 !------------------------------------------------------ 02040 !------------------------------------------------------ 02041 FUNCTION ma_cels_r118(nb,x,nbo,y) 02042 USE mod_kinds_model 02043 02044 IMPLICIT NONE 02045 02046 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_cels_r118 02047 REAL (kind=ip_double_p) ::x(nb),y(nbo) 02048 02049 DO i=1,nb 02050 y(i) = x(i)-273.15 02051 ENDDO 02052 02053 nbo = nb 02054 ma_cels_r118 = 0 02055 02056 02057 END FUNCTION ma_cels_r118 02058 !------------------------------------------------------ 02059 !------------------------------------------------------ 02060 !------------------------------------------------------ 02061 FUNCTION ma_kelv_r118(nb,x,nbo,y) 02062 USE mod_kinds_model 02063 02064 IMPLICIT NONE 02065 02066 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_kelv_r118 02067 REAL (kind=ip_double_p) ::x(nb),y(nbo) 02068 02069 DO i=1,nb 02070 y(i) = x(i)+273.15 02071 ENDDO 02072 02073 nbo = nb 02074 ma_kelv_r118 = 0 02075 02076 END FUNCTION ma_kelv_r118 02077 !------------------------------------------------------ 02078 !------------------------------------------------------ 02079 !------------------------------------------------------ 02080 FUNCTION ma_deg_r118(nb,x,nbo,y) 02081 USE mod_kinds_model 02082 02083 IMPLICIT NONE 02084 02085 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_deg_r118 02086 REAL (kind=ip_double_p) ::x(nb),y(nbo) 02087 DO i=1,nb 02088 y(i) = x(i)*57.29577951 02089 ENDDO 02090 02091 nbo = nb 02092 ma_deg_r118 = 0 02093 02094 END FUNCTION ma_deg_r118 02095 !------------------------------------------------------ 02096 !------------------------------------------------------ 02097 !------------------------------------------------------ 02098 FUNCTION ma_rad_r118(nb,x,nbo,y) 02099 USE mod_kinds_model 02100 02101 IMPLICIT NONE 02102 02103 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_rad_r118 02104 REAL (kind=ip_double_p) ::x(nb),y(nbo) 02105 02106 DO i=1,nb 02107 y(i) = x(i)*0.01745329252 02108 ENDDO 02109 02110 nbo = nb 02111 ma_rad_r118 = 0 02112 02113 END FUNCTION ma_rad_r118 02114 !------------------------------------------------------ 02115 !------------------------------------------------------ 02116 !------------------------------------------------------ 02117 FUNCTION ma_ident_r118(nb,x,nbo,y) 02118 USE mod_kinds_model 02119 02120 IMPLICIT NONE 02121 02122 INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_ident_r118 02123 REAL (kind=ip_double_p) ::x(nb),y(nbo) 02124 02125 DO i=1,nb 02126 y(i) = x(i) 02127 ENDDO 02128 02129 nbo = nb 02130 ma_ident_r118 = 0 02131 02132 END FUNCTION ma_ident_r118 02133 !------------------------------------------------------ 02134 !------------------------------------------------------ 02135 ! OPERATIONS (two argument) 02136 !------------------------------------------------------ 02137 !------------------------------------------------------ 02138 FUNCTION ma_add_r118(nb,x,s,nbo,y) 02139 USE mod_kinds_model 02140 02141 IMPLICIT NONE 02142 02143 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_add_r118 02144 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02145 02146 INTEGER (kind=ip_intwp_p):: i 02147 02148 DO i = 1,nb 02149 y(i) = x(i)+s 02150 ENDDO 02151 02152 nbo = nb 02153 ma_add_r118 = 0 02154 02155 END FUNCTION ma_add_r118 02156 !------------------------------------------------------ 02157 !------------------------------------------------------ 02158 !------------------------------------------------------ 02159 FUNCTION ma_sub_r118(nb,x,s,nbo,y) 02160 USE mod_kinds_model 02161 02162 IMPLICIT NONE 02163 02164 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_sub_r118 02165 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02166 02167 INTEGER (kind=ip_intwp_p):: i 02168 02169 DO i = 1,nb 02170 y(i) = x(i)-s 02171 ENDDO 02172 02173 nbo = nb 02174 ma_sub_r118 = 0 02175 02176 END FUNCTION ma_sub_r118 02177 !------------------------------------------------------ 02178 !------------------------------------------------------ 02179 !------------------------------------------------------ 02180 FUNCTION ma_subi_r118(nb,x,s,nbo,y) 02181 USE mod_kinds_model 02182 02183 IMPLICIT NONE 02184 02185 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_subi_r118 02186 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02187 02188 INTEGER (kind=ip_intwp_p):: i 02189 02190 DO i = 1,nb 02191 y(i) = s-x(i) 02192 ENDDO 02193 02194 nbo = nb 02195 ma_subi_r118 = 0 02196 02197 END FUNCTION ma_subi_r118 02198 !------------------------------------------------------ 02199 !------------------------------------------------------ 02200 !------------------------------------------------------ 02201 FUNCTION ma_mult_r118(nb,x,s,nbo,y) 02202 USE mod_kinds_model 02203 02204 IMPLICIT NONE 02205 02206 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_mult_r118 02207 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02208 02209 INTEGER (kind=ip_intwp_p):: i 02210 02211 DO i = 1,nb 02212 y(i) = x(i)*s 02213 ENDDO 02214 02215 nbo = nb 02216 ma_mult_r118 = 0 02217 02218 END FUNCTION ma_mult_r118 02219 !------------------------------------------------------ 02220 !------------------------------------------------------ 02221 !------------------------------------------------------ 02222 FUNCTION ma_div_r118(nb,x,s,nbo,y) 02223 USE mod_kinds_model 02224 02225 IMPLICIT NONE 02226 02227 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_div_r118 02228 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02229 02230 INTEGER (kind=ip_intwp_p):: i 02231 02232 DO i = 1,nb 02233 y(i) = x(i)/s 02234 ENDDO 02235 02236 nbo = nb 02237 ma_div_r118 = 0 02238 02239 END FUNCTION ma_div_r118 02240 !------------------------------------------------------ 02241 !------------------------------------------------------ 02242 !------------------------------------------------------ 02243 FUNCTION ma_divi_r118(nb,x,s,nbo,y) 02244 USE mod_kinds_model 02245 02246 IMPLICIT NONE 02247 02248 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_divi_r118 02249 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02250 02251 INTEGER (kind=ip_intwp_p):: i 02252 02253 DO i = 1,nb 02254 y(i) = s/x(i) 02255 ENDDO 02256 02257 nbo = nb 02258 ma_divi_r118 = 0 02259 02260 END FUNCTION ma_divi_r118 02261 !------------------------------------------------------ 02262 !------------------------------------------------------ 02263 !------------------------------------------------------ 02264 FUNCTION ma_power_r118(nb,x,s,nbo,y) 02265 USE mod_kinds_model 02266 02267 IMPLICIT NONE 02268 02269 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_power_r118 02270 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02271 02272 INTEGER (kind=ip_intwp_p):: i 02273 02274 DO i = 1,nb 02275 y(i) = x(i) ** s 02276 ENDDO 02277 02278 nbo = nb 02279 ma_power_r118 = 0 02280 02281 END FUNCTION ma_power_r118 02282 !------------------------------------------------------ 02283 !------------------------------------------------------ 02284 !------------------------------------------------------ 02285 FUNCTION ma_fumin_r118(nb,x,s,nbo,y) 02286 USE mod_kinds_model 02287 02288 IMPLICIT NONE 02289 02290 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_fumin_r118 02291 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02292 02293 INTEGER (kind=ip_intwp_p):: i 02294 02295 DO i = 1,nb 02296 y(i) = min(x(i),s) 02297 ENDDO 02298 02299 nbo = nb 02300 ma_fumin_r118 = 0 02301 02302 END FUNCTION ma_fumin_r118 02303 !------------------------------------------------------ 02304 !------------------------------------------------------ 02305 !------------------------------------------------------ 02306 FUNCTION ma_fumax_r118(nb,x,s,nbo,y) 02307 USE mod_kinds_model 02308 02309 IMPLICIT NONE 02310 02311 INTEGER (kind=ip_intwp_p):: nb,nbo,ma_fumax_r118 02312 REAL (kind=ip_double_p) ::x(nb),s,y(nbo) 02313 02314 INTEGER (kind=ip_intwp_p):: i 02315 02316 DO i = 1,nb 02317 y(i) = max(x(i),s) 02318 ENDDO 02319 02320 nbo = nb 02321 ma_fumax_r118 = 0 02322 02323 END FUNCTION ma_fumax_r118 02324 !------------------------------------------------------ 02325 !------------------------------------------------------ 02326 !------------------------------------------------------ 02327 FUNCTION ma_fuscat_r118(nb,x,nbi,ind,miss_val,nbo,y) 02328 USE mod_kinds_model 02329 02330 IMPLICIT NONE 02331 02332 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuscat_r118 02333 INTEGER (kind=ip_intwp_p):: ind(nbi) 02334 REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo) 02335 02336 INTEGER (kind=ip_intwp_p):: i,ii,ipos 02337 02338 ma_fuscat_r118 = 0 02339 02340 DO i = 1,nbo 02341 y(i) = miss_val 02342 ENDDO 02343 02344 IF (nbi <= nb) THEN 02345 02346 ipos = 0 02347 DO i = 1,nbi 02348 IF (ind(i) <= nbo .AND. ind(i) > 0) THEN 02349 ipos = ipos+1 02350 y(ind(i)) = x(ipos) 02351 ELSE 02352 IF (ind(i) > nbo) ma_fuscat_r118 = ma_fuscat_r118+1 02353 ENDIF 02354 ENDDO 02355 ! 02356 ! Repeate the data if needed 02357 ! 02358 IF (MINVAL(ind) < 0) THEN 02359 DO i = 1,nbi 02360 IF (ind(i) <= 0) THEN 02361 DO ii=1,ABS(ind(i))-1 02362 IF (ind(i+1)+ii <= nbo) THEN 02363 y(ind(i+1)+ii) = y(ind(i+1)) 02364 ELSE 02365 ma_fuscat_r118 = ma_fuscat_r118+1 02366 ENDIF 02367 ENDDO 02368 ENDIF 02369 ENDDO 02370 ENDIF 02371 ! 02372 ELSE 02373 02374 ma_fuscat_r118 = 1 02375 02376 ENDIF 02377 02378 END FUNCTION ma_fuscat_r118 02379 !------------------------------------------------------ 02380 !------------------------------------------------------ 02381 !------------------------------------------------------ 02382 FUNCTION ma_fugath_r118(nb,x,nbi,ind,miss_val,nbo,y) 02383 USE mod_kinds_model 02384 02385 IMPLICIT NONE 02386 02387 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fugath_r118 02388 INTEGER (kind=ip_intwp_p):: ind(nbi) 02389 REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo) 02390 02391 INTEGER (kind=ip_intwp_p):: i,ipos 02392 02393 IF (nbi <= nbo) THEN 02394 02395 ma_fugath_r118 = 0 02396 02397 DO i=1,nbo 02398 y(i) = miss_val 02399 ENDDO 02400 02401 ipos = 0 02402 DO i = 1,nbi 02403 IF (ipos+1 <= nbo) THEN 02404 IF (ind(i) > 0) THEN 02405 ipos = ipos+1 02406 y(ipos) = x(ind(i)) 02407 ENDIF 02408 ELSE 02409 IF (ipos+1 > nbo) ma_fugath_r118 = ma_fugath_r118+1 02410 ENDIF 02411 ENDDO 02412 02413 ELSE 02414 02415 ma_fugath_r118 = 1 02416 02417 ENDIF 02418 02419 nbo = ipos 02420 02421 END FUNCTION ma_fugath_r118 02422 !------------------------------------------------------ 02423 !------------------------------------------------------ 02424 !------------------------------------------------------ 02425 FUNCTION ma_fufill_r118(nb,x,nbi,ind,miss_val,nbo,y) 02426 USE mod_kinds_model 02427 02428 IMPLICIT NONE 02429 02430 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fufill_r118 02431 INTEGER (kind=ip_intwp_p):: ind(nbi) 02432 REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo) 02433 02434 INTEGER (kind=ip_intwp_p):: i,ii,ipos 02435 02436 ma_fufill_r118 = 0 02437 02438 IF (nbi <= nb) THEN 02439 02440 ipos = 0 02441 DO i = 1,nbi 02442 IF (ind(i) <= nbo .AND. ind(i) > 0) THEN 02443 ipos = ipos+1 02444 y(ind(i)) = x(ipos) 02445 ELSE 02446 IF (ind(i) > nbo) ma_fufill_r118 = ma_fufill_r118+1 02447 ENDIF 02448 ENDDO 02449 ! 02450 ! Repeate the data if needed 02451 ! 02452 IF (MINVAL(ind) < 0) THEN 02453 DO i = 1,nbi 02454 IF (ind(i) <= 0) THEN 02455 DO ii=1,ABS(ind(i))-1 02456 IF (ind(i+1)+ii <= nbo) THEN 02457 y(ind(i+1)+ii) = y(ind(i+1)) 02458 ELSE 02459 ma_fufill_r118 = ma_fufill_r118+1 02460 ENDIF 02461 ENDDO 02462 ENDIF 02463 ENDDO 02464 ENDIF 02465 02466 ELSE 02467 02468 ma_fufill_r118 = 1 02469 02470 ENDIF 02471 02472 END FUNCTION ma_fufill_r118 02473 !------------------------------------------------------ 02474 !------------------------------------------------------ 02475 !------------------------------------------------------ 02476 FUNCTION ma_fucoll_r118(nb,x,nbi,ind,miss_val,nbo,y) 02477 USE mod_kinds_model 02478 02479 IMPLICIT NONE 02480 02481 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fucoll_r118 02482 INTEGER (kind=ip_intwp_p):: ind(nbi) 02483 REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo) 02484 02485 INTEGER (kind=ip_intwp_p):: i,ipos 02486 02487 IF (nbi <= nbo) THEN 02488 02489 ma_fucoll_r118 = 0 02490 02491 ipos = 0 02492 DO i = 1,nbi 02493 ! 02494 IF (ipos+1 <= nbo) THEN 02495 IF (ind(i) > 0) THEN 02496 ipos = ipos+1 02497 y(ipos) = x(ind(i)) 02498 ENDIF 02499 ELSE 02500 IF (ipos+1 > nbo) ma_fucoll_r118 = ma_fucoll_r118+1 02501 ENDIF 02502 ENDDO 02503 ! 02504 ELSE 02505 ! 02506 ma_fucoll_r118 = 1 02507 ! 02508 ENDIF 02509 02510 nbo = ipos 02511 02512 END FUNCTION ma_fucoll_r118 02513 !------------------------------------------------------ 02514 !------------------------------------------------------ 02515 !------------------------------------------------------ 02516 !------------------------------------------------------ 02517 FUNCTION ma_fuundef_r118(nb,x,nbi,ind,miss_val,nbo,y) 02518 USE mod_kinds_model 02519 02520 IMPLICIT NONE 02521 02522 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuundef_r118 02523 INTEGER (kind=ip_intwp_p):: ind(nbi) 02524 REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo) 02525 02526 INTEGER (kind=ip_intwp_p):: i 02527 02528 IF (nbi <= nbo .AND. nbo == nb) THEN 02529 02530 ma_fuundef_r118 = 0 02531 02532 DO i=1,nbo 02533 y(i) = x(i) 02534 ENDDO 02535 02536 DO i = 1,nbi 02537 IF (ind(i) <= nbo .AND. ind(i) > 0) THEN 02538 y(ind(i)) = miss_val 02539 ELSE 02540 IF (ind(i) > nbo) ma_fuundef_r118 = ma_fuundef_r118+1 02541 ENDIF 02542 ENDDO 02543 02544 ELSE 02545 02546 ma_fuundef_r118 = 1 02547 02548 ENDIF 02549 02550 END FUNCTION ma_fuundef_r118 02551 !------------------------------------------------------ 02552 !------------------------------------------------------ 02553 !------------------------------------------------------ 02554 FUNCTION ma_fuonly_r118(nb,x,nbi,ind,miss_val,nbo,y) 02555 USE mod_kinds_model 02556 02557 IMPLICIT NONE 02558 02559 INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuonly_r118 02560 INTEGER (kind=ip_intwp_p):: ind(nbi) 02561 REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo) 02562 02563 INTEGER (kind=ip_intwp_p):: i 02564 02565 IF (nbi <= nbo .AND. nbo == nb) THEN 02566 02567 ma_fuonly_r118 = 0 02568 02569 DO i=1,nbo 02570 y(i) = miss_val 02571 ENDDO 02572 02573 DO i = 1,nbi 02574 IF (ind(i) <= nbo .AND. ind(i) > 0) THEN 02575 y(ind(i)) = x(ind(i)) 02576 ELSE 02577 IF (ind(i) > nbo) ma_fuonly_r118 = ma_fuonly_r118+1 02578 ENDIF 02579 ENDDO 02580 02581 ELSE 02582 02583 ma_fuonly_r118 = 1 02584 02585 ENDIF 02586 02587 END FUNCTION ma_fuonly_r118 02588 != 02589 SUBROUTINE moycum_r4 (opp,np,px,py,pwx) 02590 !--------------------------------------------------------------------- 02591 !- Does time operations 02592 !--------------------------------------------------------------------- 02593 USE mod_comprism_proto 02594 IMPLICIT NONE 02595 !- 02596 CHARACTER(LEN=7) :: opp 02597 INTEGER (kind=ip_intwp_p) :: np 02598 INTEGER (kind=ip_intwp_p) ,PARAMETER :: ierrh=3 02599 REAL (kind=ip_single_p),DIMENSION(:) :: px,py 02600 INTEGER (kind=ip_intwp_p) :: pwx 02601 !--------------------------------------------------------------------- 02602 ! 02603 IF (pwx /= 0) THEN 02604 IF (opp == 'ave') THEN 02605 px(1:np)=(px(1:np)*pwx+py(1:np))/REAL(pwx+1,kind=ip_single_p) 02606 ELSE IF (opp == 't_sum') THEN 02607 px(1:np)=px(1:np)+py(1:np) 02608 ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN 02609 px(1:np)=MIN(px(1:np),py(1:np)) 02610 ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN 02611 px(1:np)=MAX(px(1:np),py(1:np)) 02612 ELSE 02613 CALL histerr(ierrh,"moycum",'Unknown time operation',opp,' ') 02614 ENDIF 02615 ELSE 02616 IF (opp == 'l_min') THEN 02617 px(1:np)=MIN(px(1:np),py(1:np)) 02618 ELSE IF (opp == 'l_max') THEN 02619 px(1:np)=MAX(px(1:np),py(1:np)) 02620 ELSE 02621 px(1:np)=py(1:np) 02622 ENDIF 02623 ENDIF 02624 ! 02625 !----------------------- 02626 END SUBROUTINE moycum_r4 02627 != 02628 SUBROUTINE moycum_r8 (opp,np,px,py,pwx) 02629 !--------------------------------------------------------------------- 02630 !- Does time operations 02631 !--------------------------------------------------------------------- 02632 USE mod_comprism_proto 02633 IMPLICIT NONE 02634 !- 02635 CHARACTER(LEN=7) :: opp 02636 INTEGER (kind=ip_intwp_p) :: np 02637 INTEGER (kind=ip_intwp_p) ,PARAMETER :: ierrh=3 02638 REAL (kind=ip_double_p),DIMENSION(:) :: px,py 02639 INTEGER (kind=ip_intwp_p) :: pwx 02640 !--------------------------------------------------------------------- 02641 ! 02642 IF (pwx /= 0) THEN 02643 IF (opp == 'ave') THEN 02644 px(1:np)=(px(1:np)*pwx+py(1:np))/REAL(pwx+1,kind=ip_double_p) 02645 ELSE IF (opp == 't_sum') THEN 02646 px(1:np)=px(1:np)+py(1:np) 02647 ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN 02648 px(1:np)=MIN(px(1:np),py(1:np)) 02649 ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN 02650 px(1:np)=MAX(px(1:np),py(1:np)) 02651 ELSE 02652 CALL histerr(ierrh,"moycum",'Unknown time operation',opp,' ') 02653 ENDIF 02654 ELSE 02655 IF (opp == 'l_min') THEN 02656 px(1:np)=MIN(px(1:np),py(1:np)) 02657 ELSE IF (opp == 'l_max') THEN 02658 px(1:np)=MAX(px(1:np),py(1:np)) 02659 ELSE 02660 px(1:np)=py(1:np) 02661 ENDIF 02662 ENDIF 02663 ! 02664 !----------------------- 02665 END SUBROUTINE moycum_r8 02666 != 02667 !----------------- 02668 END MODULE mathelp_psmile
1.7.4 
