File: C:\NOAA\NEMS_11731\src\chem\gocart\src\GMAO_Shared\MAPL_Base\MAPL_ArthParser.F90

1     ! $Id: MAPL_ArthParser.F90,v 1.23 2008/01/09 16:19:09 f4mjs Exp $
2     
3     #include "MAPL_Generic.h"
4     
5     module MAPL_ArthParserMod
6     
7       use ESMF_Mod
8       use MAPL_BaseMod
9     
10       implicit none
11     
12       private
13     
14       public Mapl_ExpressionEvaluate
15       public Mapl_ExpressionGetVars
16     
17       integer, parameter :: MXREG = 99
18     
19       type RealPtrs
20          integer       :: rank        = 0
21          real, pointer :: Ptr2(:,:  ) => null()
22          real, pointer :: Ptr3(:,:,:) => null()
23       end type RealPtrs
24     
25       type ParserType
26          type(RealPtrs)          :: REGVAR(MXREG)
27          type(RealPtrs)          :: Left
28          type(RealPtrs)          :: Right
29          type(RealPtrs), pointer :: B(:) => null()
30          real                    :: UNDEF
31          integer                 :: IM, JM, LM
32       end type ParserType
33     
34     contains
35     
36     subroutine MAPL_ExpressionEvaluate(Expression,Bundle,Undef,Ptr2,Ptr3,rc)
37     
38       character*(*),     intent(IN   ) :: Expression
39       type(ESMF_Bundle), intent(IN   ) :: Bundle
40       real,              intent(IN   ) :: Undef
41       real,    optional, pointer       :: Ptr2(:,:)
42       real,    optional, pointer       :: Ptr3(:,:,:)
43       integer, optional, intent(  OUT) :: RC
44     
45       character(len=ESMF_MAXSTR)  :: Iam='MAPL_ExpressionEvaluate'
46       integer                     :: status
47     
48       type(ParserType), target    :: Parser 
49       integer                     :: n, nbeg, nend
50     
51       character*(len(Expression)) :: EXPR, NEWEXPR
52       integer                     :: ResultReg
53       type(RealPtrs),  pointer    :: Result
54     
55       character(len=ESMF_MAXSTR), &
56                       allocatable :: NAMES(:)
57     
58     ! Begin
59     !------
60     
61     ! One of the result pointers must be present
62     !-------------------------------------------
63     
64       ASSERT_(present(Ptr2) .or. present(Ptr3))
65     
66     ! Make a copy of the original expression so that we can modify it
67     !----------------------------------------------------------------
68     
69       NEWEXPR = Expression
70     
71     ! Initialize Parser structure with variable list and 
72     !  array dimensions from the Bundle.
73     !---------------------------------------------------
74     
75       call MAPL_BundleGetDataPtrs(Bundle,Parser%B,Parser%IM,Parser%JM,Parser%LM,RC=STATUS)
76       VERIFY_(STATUS)
77     
78       Parser%Undef = Undef
79     
80     ! Left and Right are used to hold scalars; these are always 2-d
81     !--------------------------------------------------------------
82     
83       call AllocatePtrs(Parser%Left ,Parser%IM,Parser%JM,rc=STATUS); VERIFY_(STATUS)
84       call AllocatePtrs(Parser%Right,Parser%IM,Parser%JM,rc=STATUS); VERIFY_(STATUS)
85     
86     ! Process parenthetical expressions
87     !----------------------------------
88     
89       PARENS: do
90     
91     ! Find inner parens
92     !------------------
93          
94          NBEG = index(NEWEXPR,'(',BACK=.true.)
95     
96     !  If none, evaluate final simple expression and exit
97     !----------------------------------------------------
98     
99          if(NBEG == 0) then
100             call EvalSimpleExpr(NEWEXPR,Parser,ResultReg,RC=STATUS)
101             VERIFY_(STATUS)
102             exit
103          end if
104     
105     ! Put exprssion contained in the parens into EXPR
106     !------------------------------------------------
107     
108          NEND = index(NEWEXPR(NBEG+1:),')') + NBEG
109          EXPR = NEWEXPR(NBEG+1:NEND-1)
110     
111     ! We do not allow empty parens
112     !-----------------------------
113     
114          ASSERT_(len(trim(EXPR)) > 0)
115     
116     ! Evaluate deepest parenthetical expression and put the 
117     !  result in a register. EXPR now contains the 3 character
118     !  id of the result register.
119     !---------------------------------------------------------
120     
121          call EvalSimpleExpr(EXPR,Parser,ResultReg,RC=STATUS)
122          VERIFY_(STATUS)
123     
124     ! Replace the parenthetical expression and its surrounding parens
125     !   with a register id in the full expression (NewExpr).
126     !----------------------------------------------------------------
127     
128          NewExpr = adjustl(trim(NewExpr(:NBEG-1))//trim(adjustl(EXPR))//adjustl(NewExpr(NEND+1:)))
129     
130       end do PARENS
131     
132     ! At this point only one register should be allocated and it
133     !  should contain the result.
134       
135       Result => Parser%RegVar(ResultReg)
136     
137     !  N = count(associated(Parser%RegVar(:)%Ptr2)) + &
138     !      count(associated(Parser%RegVar(:)%Ptr3))
139     !
140     !  ASSERT_(N==1)
141     
142     ! Copy result pointers, checking for consistency between
143     !   rank of result and available operands.
144     !-------------------------------------------------------
145     
146       if(present(Ptr2)) then
147          if(Result%rank==2) then
148             Ptr2 => Result%Ptr2
149          else
150             Ptr2 => null()
151             ASSERT_(present(Ptr3))
152          end if
153       endif
154     
155       if(present(Ptr3)) then
156          if(Result%rank==3) then
157             Ptr3 => Result%Ptr3
158          else
159             Ptr3 => null()
160             ASSERT_(present(Ptr2))
161          end if
162       endif
163     
164     ! Clean-up
165     !---------
166     
167       call DeallocPtrs(Parser%Left )
168       call DeallocPtrs(Parser%Right)
169     
170       deallocate(Parser%B)
171     
172       RETURN_(ESMF_SUCCESS)
173     end subroutine  MAPL_ExpressionEvaluate
174     
175     !===========================================================
176     
177     subroutine EvalSimpleExpr(EXPR,Parser,ResultReg,rc)
178       character*(*),    intent(INOUT) :: EXPR
179       type(ParserType), intent(INOUT) :: Parser
180       integer,          intent(  OUT) :: ResultReg
181       integer,optional, intent(  OUT) :: RC
182     
183     ! Evaluates an expression without parentheses, establishing
184     !  the precedence of the arithmetic operators as:
185     !
186     !    + - lower than  * / lower than  ^ 
187     !
188     ! Each call to ProcOps treats one of these three levels
189     ! clearing all ops at that level by combining their
190     ! immediate operands from left to right.
191     !-----------------------------------------------------------
192     
193       character(len=ESMF_MAXSTR)      :: Iam='EvalSimpleExpr'
194       character(len=ESMF_MAXSTR)      :: Exp
195       integer                         :: status
196       
197     !   EXPONENTATION
198     !----------------------------
199     
200       call procOps(EXPR,'^','^',PARSER,ResultReg,RC=STATUS)
201       VERIFY_(STATUS)
202     
203     !   MULTIPLICATION AND DIVISION
204     !----------------------------
205     
206       call procOps(EXPR,'*','/',PARSER,ResultReg,RC=STATUS)
207       VERIFY_(STATUS)
208     
209     !   ADDITION AND SUBTRACTION
210     !----------------------------
211     
212       call procOps(EXPR,'+','-',PARSER,ResultReg,RC=STATUS)
213       VERIFY_(STATUS)
214     
215     ! Finally account for trivial expressions consisting of a 
216     !  single variable or scalar.
217     !--------------------------------------------------------
218     
219       if(Parser%RegVar(ResultReg)%rank==0 ) then
220          EXP = '+'//adjustl(EXPR)
221          call procOps(EXP,'+','+',PARSER,ResultReg,RC=STATUS)
222          VERIFY_(STATUS)
223       end if
224     
225       RETURN_(ESMF_SUCCESS)
226     end subroutine EvalSimpleExpr
227     
228     !===============================================================
229     
230     subroutine ProcOPS(EXPR,OP1,OP2,PARSER,ResultReg,rc)
231       character*(*),    intent(INOUT) :: EXPR
232       character*1,      intent(IN   ) :: OP1, OP2
233       type(ParserType), intent(INOUT) :: PARSER
234       integer,          intent(  OUT) :: ResultReg
235       integer,optional, intent(  OUT) :: RC
236     
237       character(len=ESMF_MAXSTR)  :: Iam='ProcOPS'
238       integer     :: pos1, pos2, status
239     
240       do
241          POS1 = index(EXPR,OP1)
242          POS2 = index(EXPR,OP2)
243     
244          if(POS1==0 .and. POS2 == 0) exit
245     
246          if(POS2 > 0 .and. (POS1==0 .or. POS2<POS1)) then
247             call DODYAD(EXPR,OP2,POS2,PARSER,ResultReg,RC=STATUS)
248             VERIFY_(STATUS)
249          else
250             call DODYAD(EXPR,OP1,POS1,PARSER,ResultReg,RC=STATUS)
251             VERIFY_(STATUS)
252          end if
253       end do
254     
255       RETURN_(ESMF_SUCCESS)
256     end subroutine ProcOPS
257     
258     !===============================================================
259     
260     subroutine  DODYAD(EXPR,OP,POS,PARSER,ResultReg,rc)
261       character*(*),    intent(INOUT) :: EXPR
262       character*1,      intent(IN   ) :: OP
263       integer,          intent(INOUT) :: POS
264       type(ParserType), intent(INOUT) :: PARSER
265       integer,          intent(  OUT) :: ResultReg
266       integer,optional, intent(  OUT) :: RC
267     
268     
269       character(len=ESMF_MAXSTR) :: Iam='DODYAD'
270       integer                    :: STATUS,n
271     
272       character*(len(EXPR))      :: ARGL, ARGR
273       character*3                :: ResultRegId
274       integer                    :: NBEG, NEND, Itmp, IPL, NREG
275       integer                    :: RegLeft, RegRight, Ndealloc, ResultRank
276       real                       :: Tmp
277     
278       type(RealPtrs) :: Left, Right
279     
280     ! Get the immediate left and right operands of the dyad with
281     !  the op at POS. On exit, EXPR contains the expression with 
282     !  the dyad replaced by 'R##' and POS the index of the first '#'
283     
284       call GetDyadArgs(EXPR,POS,ARGL,ARGR)
285     
286     ! Obtain left  and right operands.
287     !---------------------------------
288     
289       call GetOperand(ARGL, Parser%RegVar, Parser%B, Parser%Left, Op, Left, RegLeft, rc=status)
290       VERIFY_(STATUS)
291     
292       call GetOperand(ARGR, Parser%RegVar, Parser%B, Parser%Right,Op, Right,RegRight,rc=status)
293       VERIFY_(STATUS)
294     
295     ! The rank of the result is the larger of the ranks
296     !  of the two operands
297     !--------------------------------------------------
298     
299       ResultRank = max(Left%rank,Right%rank)
300     
301     ! Set the result register and find out if we need to deallocate
302     ! an operand register. If an operand register of the right
303     ! rank exists we use it for the result, if not we find an empty
304     ! slot in the register list Parser%RegVar. If we have two operand
305     ! registers or one that has lesser rank than the result, we need
306     ! to deallocate a register. This logic finds both the result
307     ! register and the one to be deallocated, if any.
308     !--------------------------------------------------------------------------
309     
310       if    (RegLeft> 0 .and. RegRight> 0) then
311          if(RegLeft>=RegRight) then
312             Ndealloc  = RegRight
313             ResultReg = RegLeft
314          else
315             Ndealloc  = RegLeft
316             ResultReg = RegRight
317          end if
318       else if(RegLeft==0 .and. RegRight==0) then
319          Ndealloc  = 0
320          ResultReg = GetRegister(Parser%RegVar,rc=status)
321          VERIFY_(STATUS)
322       else if(Regleft==0                  ) then
323          if(Parser%RegVar(RegRight)%rank == ResultRank) then
324             ResultReg = RegRight
325             Ndealloc  = 0
326          else
327             Ndealloc  = RegRight
328             ResultReg = GetRegister(Parser%RegVar,rc=status)
329             VERIFY_(STATUS)
330          end if
331       else
332          if(Parser%RegVar(RegLeft)%rank == ResultRank) then
333             Ndealloc  = 0
334             ResultReg = RegLeft
335          else
336             Ndealloc  = RegLeft
337             ResultReg = GetRegister(Parser%RegVar,rc=status)
338             VERIFY_(STATUS)
339          end if
340       end if
341     
342     ! If necassary allocate the result register
343     !------------------------------------------
344     
345       if(Parser%RegVar(ResultReg)%rank == 0) then
346          if(ResultRank==3) then
347             call AllocatePtrs(Parser%RegVar(ResultReg),Parser%IM,Parser%JM,Parser%LM,RC=status)
348             VERIFY_(STATUS)
349          else
350             call AllocatePtrs(Parser%RegVar(ResultReg),Parser%IM,Parser%JM,          RC=status)
351             VERIFY_(STATUS)
352          end if
353       endif
354     
355     ! Update the expression with the result register index
356     !-----------------------------------------------------
357     
358       write(EXPR(POS:POS+1),'(I2.2)') ResultReg
359     
360     ! Evaluate the dyadic expression R = L op R
361     !------------------------------------------
362     
363       call EvalDyad(Parser%RegVar(ResultReg), Left, Right, OP, Parser%undef)
364     
365     ! Deallocate the unneeded register. This happens
366     !  when both operands where in registers
367     !  or when a single operand register had the wrong rank.
368     !--------------------------------------------------------
369     
370       if(Ndealloc /= 0) then
371          call DeallocPtrs(Parser%RegVar(Ndealloc))
372       endif
373     
374     ! All Done
375     !---------
376     
377       RETURN_(ESMF_SUCCESS)
378     end subroutine DODYAD
379     
380     
381     !===========================================================
382     
383     subroutine EvalDyad(Result, Left,Right,OP,UNDEF,RC)
384       type(RealPtrs),   intent(IN   ) :: Left, Right
385       character*(1),    intent(IN   ) :: OP
386       real,             intent(IN   ) :: UNDEF
387       type(RealPtrs),   intent(  OUT) :: Result
388       integer,optional, intent(  OUT) :: RC
389     
390       integer                     :: status
391       character(len=ESMF_MAXSTR)  :: Iam='EvalDyad'
392     
393       ASSERT_(Left %rank>=2 .and. Left %rank<=3)
394       ASSERT_(Right%rank>=2 .and. Right%rank<=3)
395     
396       ASSERT_(Result%rank==max(Right%rank,Left%rank))
397     
398       if    (Left%rank==2 .and. Right%rank==2 ) then
399          call  L2R2(Result%Ptr2, Left%Ptr2, OP, Right%Ptr2, UNDEF)
400       elseif(Left%rank==3 .and. Right%rank==3 ) then
401          call  L3R3(Result%Ptr3, Left%Ptr3, OP, Right%Ptr3, UNDEF)
402       elseif(Left%rank==2 .and. Right%rank==3 ) then
403          call  L2R3(Result%Ptr3, Left%Ptr2, OP, Right%Ptr3, UNDEF)
404       elseif(Left%rank==3 .and. Right%rank==2 ) then
405          call  L3R2(Result%Ptr3, Left%Ptr3, OP, Right%Ptr2, UNDEF)
406       end if
407     
408       return
409     end subroutine EvalDyad
410     
411     subroutine MAPL_ExpressionGetVars(Expr,Vars,last,RC)
412       character*(*),     intent(INOUT) :: Expr
413       character*(*),     intent(INOUT) :: Vars(:)
414       integer,           intent(  OUT) :: Last
415       integer, optional, intent(  OUT) :: RC
416     
417       character(len=ESMF_MAXSTR)  :: Iam='MAPL_ExpressionGetVars'
418       integer       :: nb, nl, nv, status, PosOfSymbol
419       integer       :: Left, Right
420     
421     ! Remove blanks and check parens
422     
423       nb    = 1
424       Left  = 0
425       Right = 0
426     
427       do while(len_trim(expr(nb:))>0)
428          if(expr(nb:nb)==' ') then 
429             expr(nb:) = adjustl(expr(nb:))
430          end if
431          if    (expr(nb:nb)=='(') then
432             Left  = Left  + 1
433          elseif(expr(nb:nb)==')') then
434             Right = Right + 1
435          end if
436          nb = nb + 1
437       enddo
438     
439       ASSERT_(Left==Right)
440     
441     ! Number of variables initially in list 
442     
443       nv = count(Vars /= '')
444     
445     ! Loop over expr string looking for variables and replacing them
446     ! with their 2-digit index into the vars array. If the are not
447     ! present in the vars array, they are added to it and nv is bumped.
448       
449       nb    = 1
450       do
451          PosOfSymbol =  scan(expr(nb:),'+-*/^()')
452     
453          if(PosOfSymbol==1) then
454             nb = nb + 1
455          else
456             if(PosOfSymbol==0) then
457                nl = len_trim(expr)
458             else
459                nl = nb + PosOfSymbol - 2
460             end if
461     
462             call ReplaceToken(expr,nb,nl,nv,Vars,rc=status)
463             VERIFY_(STATUS)
464          endif
465     
466          if(nb>len_trim(expr)) exit
467       end do
468     
469       Last = NV
470     
471       RETURN_(ESMF_SUCCESS)
472     
473     
474     end subroutine MAPL_ExpressionGetVars
475     
476     
477     subroutine ReplaceToken(expr,nb,nl,nv,vv,rc)
478     
479       character*(*),     intent(INOUT) :: expr
480       character*(*),     intent(INOUT) :: vv(:)
481       integer,           intent(INOUT) :: nb,nv
482       integer,           intent(IN   ) :: nl
483       integer, optional, intent(  OUT) :: RC
484     
485       character(len=ESMF_MAXSTR)  :: Iam='ReplaceToken'
486       character(len=ESMF_MAXSTR)  :: Tmp
487       integer                     :: l, status
488     
489     
490       if(index(expr(nb:nl),'.') == 0) then
491          ASSERT_(scan(expr(nb:nb),'0123456789')==0)
492          tmp  = expr(nl+1:)
493          do l=1,nv
494             if(vv(l)==adjustl(expr(nb:nl))) exit
495          enddo
496     
497          if(L==nv+1) then
498             ASSERT_(L<=size(vv))
499             nv = L
500             vv(nv) = adjustl(expr(nb:nl))
501          end if
502     
503          write(expr(nb:nb+1),'(i2.2)',iostat=status) l
504          VERIFY_(STATUS)
505     
506          nb = nb+3
507          expr(nb-1:) = adjustl(tmp)
508       else
509          ASSERT_(scan(expr(nb:nb),'0123456789')/=0)
510          nb = nl+2
511       endif
512     
513       RETURN_(ESMF_SUCCESS)
514     end subroutine ReplaceToken
515     
516     subroutine MAPL_BundleGetDataPtrs(Bundle,Result,im,jm,lm,rc)
517       type(ESMF_Bundle),      intent(IN   ) :: Bundle
518       type(RealPtrs), pointer               :: Result(:)
519       integer,                intent(  OUT) :: im, jm, lm
520       integer, optional,      intent(  OUT) :: RC
521     
522       character(len=ESMF_MAXSTR)  :: Iam='MAPL_BundleGetDataPtrs'
523       character(len=ESMF_MAXSTR), pointer  :: names(:)
524     
525       integer          :: status
526       integer          :: nrec,n
527       type(ESMF_Field) :: Field
528       type(ESMF_Array) :: Array
529     
530     
531       call ESMF_BundleGet(Bundle,fieldCount=NREC,RC=STATUS)
532       VERIFY_(STATUS)
533     
534       allocate(Result(NREC), stat=status)     
535       VERIFY_(STATUS)
536       allocate(NAMES (NREC), stat=status)     
537       VERIFY_(STATUS)
538     
539       call ESMF_BundleGetFieldNames(Bundle,nameList=NAMES,RC=STATUS)
540       VERIFY_(STATUS)
541     
542       im = -1
543       jm = -1
544       lm = -1
545     
546       do N=1,NREC
547          call ESMF_BundleGetDataPointer(Bundle,names(n),Result(N)%Ptr2,rc=status)
548          if(STATUS/=ESMF_SUCCESS) then
549     
550             call ESMF_BundleGetDataPointer(Bundle,names(n),Result(N)%Ptr3,rc=status)
551             VERIFY_(STATUS)
552             if(im==-1) then
553                im = size(Result(N)%Ptr3,1)
554                jm = size(Result(N)%Ptr3,2)
555             else
556                ASSERT_(IM==size(Result(N)%Ptr3,1))
557                ASSERT_(JM==size(Result(N)%Ptr3,2))
558             end if
559             if(lm==-1) then
560                lm = size(Result(N)%Ptr3,3)
561             else
562                ASSERT_(LM==size(Result(N)%Ptr3,3))
563             end if
564             Result(N)%rank = 3
565             nullify(Result(N)%Ptr2)
566     
567          else
568     
569             if(im==-1) then
570                im = size(Result(N)%Ptr2,1)
571                jm = size(Result(N)%Ptr2,2)
572             else
573                ASSERT_(IM==size(Result(N)%Ptr2,1))
574                ASSERT_(JM==size(Result(N)%Ptr2,2))
575             end if
576             Result(N)%rank = 2
577             nullify(Result(N)%Ptr3)
578     
579          endif
580       end do
581       lm = max(1,lm)
582       deallocate(NAMES)
583     
584       RETURN_(ESMF_SUCCESS)
585     end subroutine MAPL_BundleGetDataPtrs
586     
587     subroutine NullifyPtrs(A)
588       type(RealPtrs), intent(INOUT) :: A
589       A%rank = 0
590       nullify(A%Ptr2)
591       nullify(A%Ptr3)
592     end subroutine NullifyPtrs
593     
594     subroutine DeallocPtrs(A)
595       type(RealPtrs), intent(INOUT) :: A
596       if(associated(A%Ptr2)) deallocate(A%Ptr2)
597       if(associated(A%Ptr3)) deallocate(A%Ptr3)
598       call NullifyPtrs(A)
599     end subroutine DeallocPtrs
600     
601     
602     subroutine AllocatePtrs(A,IM,JM,LM,RC)
603       type(RealPtrs),   intent(INOUT) :: A
604       integer,          intent(IN   ) :: IM, JM
605       integer,optional, intent(IN   ) :: LM
606       integer,optional, intent(  OUT) :: RC
607     
608       integer STATUS
609       character(len=ESMF_MAXSTR)  :: Iam='AllocatePtrs'
610     
611       if(present(LM)) then
612          A%rank = 3
613          nullify(A%Ptr2)
614          allocate(A%Ptr3(IM,JM,LM),stat=status)
615          VERIFY_(STATUS)
616       else
617          A%rank = 2
618          nullify(A%Ptr3)
619          allocate(A%Ptr2(IM,JM   ),stat=status)
620          VERIFY_(STATUS)
621       end if
622     
623       RETURN_(ESMF_SUCCESS)
624     end subroutine AllocatePtrs
625     
626     !=================================================================
627     
628     subroutine GetDyadArgs(EXPR,POS,ARGL,ARGR)
629       character*(*),    intent(INOUT) :: EXPR
630       integer,          intent(INOUT) :: POS
631       character*(*),    intent(  OUT) :: ARGL
632       character*(*),    intent(  OUT) :: ARGR
633     
634       integer :: nbeg, nend
635       
636       ARGL = adjustl(EXPR(:POS-1))
637       ARGR = adjustl(EXPR(POS+1:))
638     
639       NBEG = scan(ARGL,'+-*/^',BACK=.true.) + 1
640       NEND = scan(ARGR,'+-*/^')
641     
642       ARGL = ARGL(nbeg:)  
643     
644       if(NEND /= 0) then
645          NEND = NEND - 1
646          ARGR = adjustl(ARGR(:NEND))
647       else
648          NEND = len(trim(ARGR))
649       end if
650     
651     ! Replace the dyad 'L op R' with the id of the result register
652     !-------------------------------------------------------------
653     
654       EXPR = EXPR(:NBEG-1)//'R##'//EXPR(NEND+POS+1:)
655       POS  = NBEG+1
656     
657       return
658     end subroutine GetDyadArgs
659     
660     
661     function GetRegister(List,rc) result(Register)
662       type(RealPtrs),   intent(IN   ) :: List(:)
663       integer                         :: Register
664       integer,optional, intent(  OUT) :: RC
665     
666       character(len=ESMF_MAXSTR)  :: Iam='GetRegister'
667     
668     ! Look for an empty register
669     !---------------------------
670     
671       Register=1
672       do while(List(Register)%rank>0) 
673          Register=Register+1
674          ASSERT_(Register<=MXREG)
675       end do
676     
677       RETURN_(ESMF_SUCCESS)
678     end function GetRegister
679     
680     
681     subroutine GetOperand(OprndString, RegList, VarList, Tmp, Op, Operand, Reg, rc)
682       character*(*),    intent(IN   ) :: OprndString
683       type(RealPtrs),   intent(IN   ) :: RegList(:), VarList(:)
684       type(RealPtrs),   intent(INOUT) :: Tmp
685       character*(1),    intent(IN   ) :: Op
686       type(RealPtrs),   intent(  OUT) :: Operand
687       integer,          intent(  OUT) :: Reg
688       integer,optional, intent(  OUT) :: RC
689     
690     ! Get the actual operand from the operand char string.
691     !  Operand is contained in a RealPtr structure.
692     !----------------------------------------------------
693     
694       character(len=ESMF_MAXSTR)  :: Iam='GetOperand'
695       real    :: scalar
696       integer :: VarNum
697     
698     
699     ! Reg is 0 if it anything other than a register; 
700     !  otherwise, it is the register index.
701     !-----------------------------------------------
702     
703       Reg  = index(OprndString,'R')
704     
705     ! Operand can be register, missing, a fixed-point float,
706     ! or a variable.
707     !-------------------------------------------------------
708     
709       if(Reg /= 0) then
710          read(OprndString(Reg:Reg+2),'(I2)') Reg
711          Operand  = RegList(Reg)
712     
713       elseif(len(trim(OprndString))==0 .and. (OP=='+' .or. OP=='-')) then
714          Tmp%Ptr2 = 0.0
715          Operand  = Tmp
716     
717       elseif(index(OprndString,'.') /= 0) then
718          read(OprndString,*) Scalar
719          Tmp%Ptr2 = Scalar
720          Operand  = Tmp
721     
722       else
723          read(OprndString,*) VarNum
724          ASSERT_(VarNum <= size(VarList))
725          Operand  = VarList(VarNum)
726       end if
727     
728       RETURN_(ESMF_SUCCESS)
729     end subroutine GetOperand
730     
731     
732     subroutine L2R2(Y,L,OP,R,Undef)
733       real,          intent(IN) :: L(:,:), R(:,:)
734       character*1,   intent(IN) :: OP
735       real,          intent(IN) :: Undef
736       real,          intent(OUT):: Y(:,:)
737       
738       Y = UNDEF
739     
740       select case (OP)
741       case ('+')
742          where(L/=UNDEF .and. R/=UNDEF                ) Y = L +  R
743       case ('-')
744          where(L/=UNDEF .and. R/=UNDEF                ) Y = L -  R
745       case ('*')
746          where(L/=UNDEF .and. R/=UNDEF                ) Y = L *  R
747       case ('/')
748          where(L/=UNDEF .and. R/=UNDEF .and. R  /= 0.0) Y = L /  R
749       case ('^')
750          where(L/=UNDEF .and. R/=UNDEF .and. L  >= 0.0) Y = L ** R
751       end select
752     
753       return
754     end subroutine L2R2
755     
756     
757     subroutine L2R3(Y,L,OP,R,Undef)
758       real,          intent(IN) :: L(:,:), R(:,:,:)
759       character*(*), intent(IN) :: OP
760       real,          intent(IN) :: Undef
761       real,          intent(OUT):: Y(:,:,:)
762     
763       integer :: I 
764     
765       do I=1,size(R,3)
766          call L2R2(Y(:,:,I),L,op,R(:,:,I),UNDEF)
767       end do
768     
769     end subroutine L2R3
770     
771     subroutine L3R2(Y,L,OP,R,Undef)
772       real,          intent(IN) :: L(:,:,:), R(:,:)
773       character*(*), intent(IN) :: OP
774       real,          intent(IN) :: Undef
775       real,          intent(OUT):: Y(:,:,:)
776     
777       integer :: I
778     
779       do I=1,size(L,3)
780          call L2R2(Y(:,:,I),L(:,:,I),op,R,UNDEF)
781       end do
782     
783     end subroutine L3R2
784     
785     subroutine L3R3(Y,L,OP,R,Undef)
786       real,          intent(IN) :: L(:,:,:), R(:,:,:)
787       character*(*), intent(IN) :: OP
788       real,          intent(IN) :: Undef
789       real,          intent(OUT):: Y(:,:,:)
790     
791       integer :: I
792     
793       do I=1,size(L,3)
794          call L2R2(Y(:,:,I),L(:,:,I),op,R(:,:,I),UNDEF)
795       end do
796     
797     end subroutine L3R3
798     
799     end module MAPL_ArthParserMod
800