0 INTEGER*2 FUNCTION XXFVAL (KFUN,IFUN,IA,NLINES)AC_Titl XXFVAL XG system function argument setup and evaluation. IMPLICIT INTEGER*2 (M)C_Args? INTEGER KFUN ![I] The predefined function to be performed.A INTEGER*2 IFUN(10) ![I] The index to the database variable.D INTEGER*2 IA(NLINES,1) ![I] Contains requested database variables./ INTEGER NLINES ![I] Number of lines per page.C_DescMC XXFVAL sets up the arguments for any specialized user application which theKC user may wish to add to XGDATA. The following steps explain how to add aC function.CC#C To add a function:CKC A. Increment number of defined functions by 1 (NDFUN data statement and!C 2nd dimension of LFUN array).:C B. Enter column numbers of arguments for new LFUN row..C C. Enter variable definition in VARTAB.INP@C D. Add a new branch to the computed go to statement of XXFVALAC E. Insert function code at that new branch followed by return.EC column arguments are referenced by IA(1,IFUN(N)) or equivalentMC where N is argument number. THEY are all INTEGER*2 in storage units.JC function code must have the form XXFVAL = .... to evaluate a singleGC function as an INTEGER*2 item in storage units. SEQUENCE headerEC items (in COMMON/XXSCOM/) may be used. ANY function requiringHC more than a few lines of code should be evaluated in a subprogram.DC F. similarly, add a new branch to the computed go to statement ofCC the XXFARG entry, inserting initialization code: requests forCC parameters, pre-computation of constants, etc., if necessary.'C The functions currently defined are:;C *** VIKING IRTM and MAWD database: defined functions *** 8C 1 SOLAR longitude (ZLNG or l sub s) (seq dir item)8C 2 SOLAR colatitude (ZCOL) sequence directory item.2C *** VIKING irtm database: defined functions ***C 3 JULIAN date (djul) &C 4 SINGLE point inertia (i sub sp)C 5 LAMBERT albedo (a sub l) C 6 MINNAERT albedo (a sub m)'C 7 PHASE-CORRECTED albedo (a sub g)2C *** VIKING MAWD database: defined functions ***#C 8 MARS day (by bruce jakosky).C 9 WATER error code.C#.C_Calls A2AN INERSP COS EXP DAYFUN ISHFTC_Hist 82jan06 R.Mehlman UCLAIC 85nov17 H.Kieffer add tests for real_value of result being within i*2 3C range and precalculate first 2 function integers.:C 85jan26 HHK combine IRTM and MAWD (functions 8 and 9):C 87oct19 HHK variable definitions ( now done by XGVDEF)C_End INTEGER*4 IFDSQ,IZMAG3 COMMON /XXSCOM/ MSC1(7),MDSC,MXS9(2),IFDSQ,MOET(4)5 1 ,IZMAG,MZLNG,MZCOL, MJDQ1,MJDQ2, MTFPER,MXUFBQ 2 ,MVFXX(3),MLON,MSC2(92) INTEGER*2 IDENT(8), DAYFUN5 REAL INERSP, FACTI /100./ , AMAXIN /32000./ , AI(8) 0 1 , SCALEI(8) /80.,10000.,3*80.,800.,2*80./& &,RMINI2/-32767./, RMAXI2/32767./< EQUIVALENCE (AI1,AI(1)),(AI2,AI(2)),(AI3,AI(3)),(AI4,AI(4))< 1 ,(AI5,AI(5)),(AI6,AI(6)),(AI7,AI(7)),(AI8,AI(8)) INTEGER*2 LFUN(10,9) 1 /10*0 2 ,10*0 3 ,10*0 4 ,13,-5,17,5,6,12,9,7,0,0 5 ,16,7,8*0 6 ,16,7,8,7*0 7 ,-5,3,8*0 8 ,3,9*0 9 ,9,9*0/1 DATA NDFUN,MXNARG,NDENT, DAR80, MINI2 , MAXI29 1 / 9, 10, 8, 2.18166E-4, -32767, 32767/!-------XXFVAL function entry./! Convert commonly used columns to REAL. RIAF1 = IA(1,IFUN(1)) RIAF2 = IA(1,IFUN(2))!-------Branch to function.) GO TO (10,20,30,40,50,60,70,80,90),KFUN M!----- L sub s, ZLNG (code 1) from sequence directory (constant thru orbit).10 XXFVAL=MZLNG GOTO 99BC-----ZCOL (code 2) from sequence directory (constant thru orbit).20 XXFVAL=MZCOL GOTO 99LC-----JULIAN DATE (code 3) from sequence directory (constant thru sequence).30 XXFVAL=MJDQ1 GOTO 99KC-----Single point thermal inertia (code 4) using PHIL CHRISTENSEN routine.GC inertias > 320. reset to -320. RETURNED in integer*2 hundredths.40 DO 41 I=1,8I41 AI(I) = IA(1,IFUN(I))/SCALEI(I) 7 T = FACTI*INERSP(AI1,AI2,AI3,AI4,AI5,AI6,AI7,AI8)+.5 IF (T .GT. AMAXIN) T=-AMAXIN GOTO 987C-----Lambert albedo (code 5) a sub l = VB / cos(inc).$50 T = RIAF1 / COS(RIAF2*DAR80) + .5 GOTO 98PC-----Minnaert albedo (code 6) a sub m = vb * cos(inc)**(-k) * cos(emis)**(1-k).$60 T =RIAF1*COS(RIAF2 *DAR80)**AMK* 1 *COS(IA(1,IFUN(3))*DAR80)**AOMK+.5 GOTO 98OC-----Phase-corrected albedo (code 7) a sub g = a sub l * (1 + a*exp(b*phase)).*70 T = RIAF1*(1.0+AALG*EXP(BALG*RIAF2))+.5 GOTO 98'C-----Mars day (code 8) (BMJ function).80 ALON = RIAF1/80. T = DAYFUN (IFDSQ,ALON,MDSC) GOTO 98OC---Water error code (extracted from high order byte of word 9 of MAWD record).+90 XXFVAL = ISHFT (IA(1,IFUN(1)),-8) / 5.10 GOTO 99698 IF (T.GT.RMAXI2) THEN !Test for valid Int*2 result. XXFVAL = MAXI2 ELSEIF (T.LT.RMINI2) THEN XXFVAL = MINI2 ELSE XXFVAL = T ENDIF 99 RETURNPC========================== XXFARG =========================================== ENTRY XXFARG (KFUN,IFUN,IR)NCC_Title XXFARG set Column numbers's of function arguments, initial constants.CC_Arguments(CC INTEGER*2 KFUN ![I] Function number ?CC INTEGER*2 IFUN(*) ![I/O] Location of the requested function."CC INTEGER IR ![O] Error code. -CC 0 = Normal4CC -1 = Formal error.CC_Description CC_Hist started same as XXFVAL.<CC 87oct19 HHK remove all the unused potential flexibility.CC_End ( IR = 0 !Set for normal return.H IF (KFUN.LE.0.OR.KFUN.GT.NDFUN) THEN !Formal error in input arguments.7 IR=-1 !Set error return code. GOTO 9 ENDIF DO I=1,MXNARG* IF (IFUN(I).EQ.0) IFUN(I)=LFUN(I,KFUN) ENDDO&C------ Initialize physical constants.! AMK=-.95 !MINNEART ALBEDO, k=.95 AOMK=.05 & AALG=.000146 !PHASE-CORRECTED ALBEDO. BALG=.075/80.9 RETURN END