/* REXX ----------------------------------------------------------- */ /* What: DBRMMAP is a REXX exec to map a DBRM member */ /* With: Panel DBRMMAP & Messages DBRMS00 */ /* From: IDUG Insiders "Code Place" */ /* Author: Ron Root 31/08/2004 */ /* Change: Ron Brown 27/03/2006 */ /* - LIBDEFs controlled by parameter at start, & 'STACK'ed */ /* - accept srcdbrm as input argument */ /* Change: Ron Brown 20/12/2007 */ /* - DBRMLIB & DBRMMAP saved to ISPF PROFILE pool */ /* - NEWSTACK & DELSTACK added */ /* - corrected DB2 version information in output */ /* - translation table for UNICODE added */ /* - sqlstmt-text and host-varname conversion from UNICODE */ /* - increased output dataset LRECL & BLKSIZE */ /* Change: Ron Brown 09/01/2008 */ /* - show DBRM Contoken, Loadlib Token, Program Version Id */ /* - convert CONTOKEN to timestamp */ /* Change: Ron Brown 16/07/2008 */ /* - output datasetname -> tsoprefix.userid........ */ /* Change: Ron Brown 30/07/2008 */ /* - fix panel display logic */ /* - fix number of host variables (16448 is invalid) */ /* Change: Ron Brown 11/11/2008 */ /* - add extra data types for DB2 9 */ /*------------------------------------------------------------------*/ libdefs = 'NO' Arg srcdbrm /* source DBRM name can be specified as parameter */ If (SYSVAR(SYSISPF) ^= 'ACTIVE') Then Do Address TSO "ISPF CMD(%DBRMMAP "srcdbrm") PASSLIB NEWAPPL(DBRM)" Exit End Address ISPEXEC "VGET (ZAPPLID) SHARED" If (zapplid ^= 'DBRM') Then Do "SELECT CMD(%DBRMMAP "srcdbrm") PASSLIB NEWAPPL(DBRM) SCRNAME(DBRM)" Exit End If libdefs = 'YES' Then Do "LIBDEF ISPPLIB DATASET ID('???????????.PLIB') STACK" "LIBDEF ISPMLIB DATASET ID('???????????.MLIB') STACK" End If (srcdbrm <> '') Then Do args = 'Y' /* srcdbrm supplied as invocation argument */ If Left(srcdbrm,1) = "'" Then Do Parse Var srcdbrm "'" dbrmlib "(" dbrmmem ")'" srcdbrm = STRIP(srcdbrm,,"'") End Else Do If Sysvar('SYSPREF') \= '' Then srcdbrm = Sysvar('SYSPREF')!!'.'!!scrdbrm Parse Var srcdbrm dbrmlib "(" dbrmmem ")" End "CONTROL NONDISPL ENTER" End Else "VGET (DBRMLIB,DBRMMEM) PROFILE" zwinttl = 'DBRM Mapper' msgid = '' Do d = 1 to 999 Until (retcode = 8) msg2 = '' "ADDPOP ROW(3) COLUMN(6)" "DISPLAY PANEL(DBRMMAP) " msgid retcode = rc "REMPOP" If (retcode = 0) Then Do srcdbrm = STRIP(dbrmlib) !! '(' !! STRIP(dbrmmem) !! ')' srcdbrm = STRIP(TRANSLATE(srcdbrm," ","'")) If (SYSDSN("'"srcdbrm"'") <> 'OK') Then msgid = ' MSG(DBRMS003)' Else Do Call Process_DBRM msgid = '' "VPUT (DBRMLIB,DBRMMEM) PROFILE" If args = 'Y' Then Leave d End End End If libdefs = 'YES' Then Do Address ISPEXEC "LIBDEF ISPPLIB" Address ISPEXEC "LIBDEF ISPMLIB" End Exit Process_DBRM: "ADDPOP ROW(3) COLUMN(6)" "CONTROL DISPLAY LOCK" msg2 = 'Please wait. DBRMMAP is processing your DBRM member...' "DISPLAY PANEL(DBRMMAP)" "REMPOP" Drop lineout. /* Reset output lines */ count = 0 /* Set line count to 0 */ Upper srcdbrm Call FormatOutput 'SOURCE DBRM MEMBER: 'srcdbrm Call FormatOutput ' ' Address TSO "ALLOC FI(TEMPDBRM) DA('"srcdbrm"') SHR REUSE" "NEWSTACK" "EXECIO * DISKR TEMPDBRM (STEM LINE. FINIS" Call Process_DBRM_Header If (rc ^= 0) Then Exit If (line.0 <= 2) Then Do Call FormatOutput ' ' Call FormatOutput 'DBRM contains no SQL stmt!' End If (dbrmformat ^= '1') Then Do Call FormatOutput 'This pgm does not support DRBM Entry ' !!, 'Statement prior to V2.3. DBRMMAP terminates ...' Return 8 End entry = '' Do i=3 To line.0 /* Start at line 3 */ entry = entry !! line.i next = i + 1 /* If end-of-file or next line has eye-catcher 'DBRM' ... */ If (i = line.0) ! (SUBSTR(line.next,1,4) = 'DBRM') Then Do Call Process_DBRM_Entry entry entry = '' End End Call WriteAndBrowseOutput "FREE FI(TEMPDBRM)" "DELSTACK" Return /*-------------------------------------------------------------------*/ /* This procedure maps the header of DBRM */ /*-------------------------------------------------------------------*/ Process_DBRM_Header: header = line.1 !! line.2 /* 1st two lines are header info */ /* Call FormatOutput 'Length of DBRM Header = ' !!, X2D(C2X(SUBSTR(header,5,4))) */ Call FormatOutput 'Precompile Userid = 'SUBSTR(header,9,8) Call FormatOutput 'Program Name = 'SUBSTR(header,17,8) contoken = C2X(SUBSTR(header,25,8)) loadtoken = Right(contoken,8)!!Left(contoken,8) If Left(contoken,1) > '0' Then Do tod = Timestamp(contoken) Call FormatOutput 'Precompile Timestamp = 'tod End Call FormatOutput 'DBRM Contoken = 'contoken Call FormatOutput 'Loadlib Token = 'loadtoken dbrmformat = SUBSTR(header,75,1) Call FormatOutput 'Format Of Entry Stmt = 'dbrmformat !!, ' (1= format of Entry stmt in 2.3 and later)' /* Call FormatOutput 'Maximum Section Number = 'SUBSTR(header,73,2) */ If (C2X(SUBSTR(header,78,1)) = 80) Then Do /* If ON (i.e, X'80'), then header extension follows... */ db2ver = SUBSTR(header,80,1) If (db2ver = 'B') Then Call FormatOutput 'DB2 Version = V1.3' If (db2ver = 'C') Then Call FormatOutput 'DB2 Version = V2.1' If (db2ver = 'D') Then Call FormatOutput 'DB2 Version = V2.2' If (db2ver = 'E') Then Call FormatOutput 'DB2 Version = V2.3' Else If (db2ver = 'F') Then Call FormatOutput 'DB2 Version = V3' Else If (db2ver = 'G') Then Call FormatOutput 'DB2 Version = V4' Else If (db2ver = 'H') Then Call FormatOutput 'DB2 Version = V5' Else If (db2ver = 'I') Then Call FormatOutput 'DB2 Version = V6' Else If (db2ver = 'J') Then Call FormatOutput 'DB2 Version = V6' Else If (db2ver = 'K') Then Call FormatOutput 'DB2 Version = V7' Else If (db2ver = 'L') Then Call FormatOutput 'DB2 Version = V8' Else If (db2ver = 'M') Then Call FormatOutput 'DB2 Version = V9' Else Call FormatOutput 'DB2 Version = UNKNOWN ('db2ver')' End If db2ver >'D' Then Do progver = SUBSTR(header,83,64) If progver <> '' Then Call FormatOutput 'Program Version Id =' progver End If (db2ver >= 'K') Then Do /* prepare to convert from Unicode to EBCDIC */ tablei = XRANGE('00'x,'FF'x) tableo = /* conversion table for Unicode UTF-8 to EBCDIC */, '00'x'01'x'02'x'03'x'37'x'2D'x'2E'x'2F'x'16'x'05'x'25'x'0B'x !!, '0C'x'0D'x'0E'x'0F'x'10'x'11'x'12'x'13'x'3C'x'3D'x'32'x'26'x !!, '18'x'19'x'3F'x'27'x'1C'x'1D'x'1E'x'1F'x'40'x'4F'x'7F'x'7B'x !!, '5B'x'6C'x'50'x'7D'x'4D'x'5D'x'5C'x'4E'x'6B'x'60'x'4B'x'61'x !!, 'F0'x'F1'x'F2'x'F3'x'F4'x'F5'x'F6'x'F7'x'F8'x'F9'x'7A'x'5E'x !!, '4C'x'7E'x'6E'x'6F'x'7C'x'C1'x'C2'x'C3'x'C4'x'C5'x'C6'x'C7'x !!, 'C8'x'C9'x'D1'x'D2'x'D3'x'D4'x'D5'x'D6'x'D7'x'D8'x'D9'x'E2'x !!, 'E3'x'E4'x'E5'x'E6'x'E7'x'E8'x'E9'x'4A'x'E0'x'5A'x'5F'x'6D'x !!, '79'x'81'x'82'x'83'x'84'x'85'x'86'x'87'x'88'x'89'x'91'x'92'x !!, '93'x'94'x'95'x'96'x'97'x'98'x'99'x'A2'x'A3'x'A4'x'A5'x'A6'x !!, 'A7'x'A8'x'A9'x'C0'x'BB'x'D0'x'A1'x'07'x'20'x'21'x'22'x'23'x !!, '24'x'15'x'06'x'17'x'28'x'29'x'2A'x'2B'x'2C'x'09'x'0A'x'1B'x !!, '30'x'31'x'1A'x'33'x'34'x'35'x'36'x'08'x'38'x'39'x'3A'x'3B'x !!, '04'x'14'x'3E'x'FF'x'41'x'AA'x'B0'x'B1'x'9F'x'B2'x'6A'x'B5'x !!, 'BD'x'B4'x'9A'x'8A'x'BA'x'CA'x'AF'x'BC'x'90'x'8F'x'EA'x'FA'x !!, 'BE'x'A0'x'B6'x'B3'x'9D'x'DA'x'9B'x'8B'x'B7'x'B8'x'B9'x'AB'x !!, '64'x'65'x'62'x'66'x'63'x'67'x'9E'x'68'x'74'x'71'x'72'x'73'x !!, '78'x'75'x'76'x'77'x'AC'x'69'x'ED'x'EE'x'EB'x'EF'x'EC'x'BF'x !!, '80'x'FD'x'FE'x'FB'x'FC'x'AD'x'AE'x'59'x'44'x'45'x'42'x'46'x !!, '43'x'47'x'9C'x'48'x'54'x'51'x'52'x'53'x'58'x'55'x'56'x'57'x !!, '8C'x'49'x'CD'x'CE'x'CB'x'CF'x'CC'x'E1'x'70'x'DD'x'DE'x'DB'x !!, 'DC'x'8D'x'8E'x'DF'x End /* Call FormatOutput 'Copy of POPT = 'C2X(SUBSTR(header,33,40)) */ Call FormatPrecompileOptions header Call FormatOutput ' ' Call FormatOutput LEFT('', 132, '_') Return 0 /*--------------------------------------------------------------------*/ /* This procedure maps the precompile options of the DBRM */ /*--------------------------------------------------------------------*/ FormatPrecompileOptions: Parse Arg header Call FormatOutput 'Precompile Options Used: ' blanks = ' ' dec_opt = C2X(SUBSTR(header,37,1)) If (dec_opt = 80) Then Call FormatOutput blanks !! 'DEC(31)' Else Call FormatOutput blanks !! 'DEC(15)' sqlflag_opt = C2X(SUBSTR(header,39,1)) If (sqlflag_opt = 00) Then Call FormatOutput blanks !! 'SQLFLAG(STD) (a.k.a SQLFLAG(86))' Else Call FormatOutput blanks !! 'SQLFLAG(SAA) (a.k.a SQLFLAG(IBM))' datetime_opt = C2X(SUBSTR(header,36,1)) If (BITAND(datetime_opt,01) = 01) Then Call FormatOutput blanks !! 'DATE(USA)' Else If (BITAND(datetime_opt,02) = 02) Then Call FormatOutput blanks !! 'DATE(JIS) or DATE(ISO)' Else If (BITAND(datetime_opt,04) = 04) Then Call FormatOutput blanks !! 'DATE(EUR)' Else If (BITAND(datetime_opt,08) = 08) Then Call FormatOutput blanks !! 'DATE(LOCAL)' If (BITAND(datetime_opt,10) = 10) Then Call FormatOutput blanks !! 'TIME(USA)' Else If (BITAND(datetime_opt,20) = 20) Then Call FormatOutput blanks !! 'TIME(EUR) or TIME(ISO)' Else If (BITAND(datetime_opt,40) = 40) Then Call FormatOutput blanks !! 'TIME(JIS)' Else If (BITAND(datetime_opt,80) = 80) Then Call FormatOutput blanks !! 'TIME(LOCAL)' version_opt = C2X(SUBSTR(header,82,1)) If (version_opt = 1A) Then Call FormatOutput blanks !! 'VERSION(AUTO)' Else If (version_opt = 05) Then Do vernum = SUBSTR(header,83,63) Call FormatOutput blanks !! 'VERSION('STRIP(vernum)')' End other_opt = C2X(SUBSTR(header,33,1)) If (BITAND(other_opt,10) = 00) Then Call FormatOutput blanks !! 'NOGRAPHIC' Else If (BITAND(other_opt,10) = 10) Then Call FormatOutput blanks !! 'GRAPHIC' If (BITAND(other_opt,20) = 00) Then Call FormatOutput blanks !! 'APOSTSQL' Else If (BITAND(other_opt,20) = 20) Then Call FormatOutput blanks !! 'QUOTESQL' If (BITAND(other_opt,80) = 00) Then Call FormatOutput blanks !! 'APOST' Else If (BITAND(other_opt,80) = 80) Then Call FormatOutput blanks !! 'QUOTE' sql_opt = C2X(SUBSTR(header,38,1)) If (BITAND(sql_opt,01) = 01) Then Call FormatOutput blanks !! 'SQL(ALL)' Else If (BITAND(sql_opt,02) = 02) Then Call FormatOutput blanks !! 'SQL(DB2)' Return /*-------------------------------------------------------------------*/ /* This procedure maps the entries of DBRM. Each entry is located by */ /* eye-catcher 'DBRM', and each entry can have more than 1 line. If */ /* an entry has host variable info, the procedure will go ahead and */ /* map it. */ /*-------------------------------------------------------------------*/ Process_DBRM_Entry: Parse Arg entry /* Call FormatOutput 'Length of DBRM Entry = ' !!, X2D(C2X(SUBSTR(entry,5,4))) !!, ' (ENTRY+STMT+TEXT+PVAR+PVRS+PVRE+FNTX)' */ Call FormatOutput 'Section Number = ' !!, X2D(C2X(SUBSTR(entry,9,2))) Call FormatOutput 'Statement number = ' !!, X2D(C2X(SUBSTR(entry,13,4))) length = X2D(C2X(SUBSTR(entry,21,4))) /* Length of SQL stmt */ /* In DB2 version 8 the text may be returned in Unicode, *Ron*/ /* but not always. Therefore, the 1st 3 characters are *Ron*/ /* checked, and if they are not A-Z do text conversion. *Ron*/ text = SUBSTR(entry,25,length) If Datatype(Left(text,3),'M') = 0 Then /*Ron*/ text = TRANSLATE(text,tableo,tablei) /* Unicode -> EBCDIC *Ron*/ Call FormatOutput 'Statement Text =' text newindex = 25 + length /* New index is offset to # of host variables */ numhost = X2D(C2X(SUBSTR(entry,newindex,2))) /* Get # of host var's */ If numhost = 16448 Then numhost = 0 Call FormatOutput 'Number of Host Variables= ' !! numhost If (numhost > 0) Then Do hvindex = newindex + 4 /* hvindex points to 1st host-var entry */ Call FormatOutput ' HOST VAR# HOST VARIABLE NAME ' !!, ' INPUT/OUTPUT HOST VARIABLE TYPE ' Call FormatOutput ' --------- ---------------------------------'!!, ' ------------ ------------ ----------------------' Do j=1 to numhost infolen = X2D(C2X(SUBSTR(entry,hvindex,2))) /* Len each hv entry */ hvlen = X2D(C2X(SUBSTR(entry,hvindex+20,2))) /* Len of hv name */ hvname = SUBSTR(entry,hvindex+22,hvlen) /* Hv name */ /* In DB2 version 8 it may be necessary to convert from Unicode */ If hvname <> '' & Left(hvname,1) <> '*', /*Ron*/ & Datatype(Left(hvname,1),'M') = 0 Then /*Ron*/ hvname = TRANSLATE(hvname,tableo,tablei) /* Unicode -> EBCDIC */ If (C2X(SUBSTR(entry,hvindex+6,1)) = 40) Then /* INPUT/OUTPUT hv? */ hvinout = 'OUTPUT' Else hvinout = 'INPUT' type = FormatDataType(hvindex, entry) tempstr1 = LEFT(' ' !! j, 13, ' ') /* Format host var# */ tempstr2 = LEFT(hvname, 46, ' ') /* Format host var name */ tempstr3 = LEFT(hvinout, 15, ' ') /* Format in/out type */ Call FormatOutput tempstr1 !! tempstr2 !! tempstr3 !! type hvindex = hvindex + infolen End End Call FormatOutput ' ' Call FormatOutput LEFT('', 132, '_') Return FormatDataType: Procedure Parse Arg hvindex, dbrmentry hvtype = X2D(C2X(SUBSTR(dbrmentry,hvindex+15,2))) /* Hv data type */ str = '' sqlcmd = SUBSTR(dbrmentry,25,8) /* 1st 8 char's of sqltext is the cmd */ If (hvtype = 384) ! (hvtype = 385) Then Do /* DATE type */ str = 'DATE' End Else If (hvtype = 388) ! (hvtype = 389) Then Do /* TIME type */ str = 'TIME' End Else If (hvtype = 392) ! (hvtype = 393) Then Do /* TIMESTAMP type */ str = 'TIMESTAMP' End Else If (hvtype = 404) ! (hvtype = 405) Then Do /* BLOB type */ str = 'BLOB' End Else If (hvtype = 408) ! (hvtype = 409) Then Do /* CLOB type */ str = 'CLOB' End Else If (hvtype = 412) ! (hvtype = 413) Then Do /* DBCLOB type */ str = 'DBCLOB' hvlen = X2D(C2X(SUBSTR(dbrmentry,hvindex+11,4))) /* Hv length */ str = str !! '(' !! hvlen !! ')' End Else If (hvtype = 448) ! (hvtype = 449) !, (hvtype = 456) ! (hvtype = 457) Then Do /* VARCHAR type */ str = 'VARCHAR' hvlen = X2D(C2X(SUBSTR(dbrmentry,hvindex+11,4))) /* Hv length */ str = str !! '(' !! hvlen !! ')' End Else If (hvtype = 452) ! (hvtype = 453) Then Do /* CHAR type */ str = 'CHAR' hvlen = X2D(C2X(SUBSTR(dbrmentry,hvindex+11,4))) /* Hv length */ str = str !! '(' !! hvlen !! ')' End Else If (hvtype = 464) ! (hvtype = 465) !, (hvtype = 472) ! (hvtype = 473) Then Do /* VARGRAPHIC type */ str = 'VARGRAPHIC' hvlen = X2D(C2X(SUBSTR(dbrmentry,hvindex+11,4))) /* Hv length */ str = str !! '(' !! hvlen !! ')' End Else If (hvtype = 468) ! (hvtype = 469) Then Do /* GRAPHIC type */ str = 'GRAPHIC' hvlen = X2D(C2X(SUBSTR(dbrmentry,hvindex+11,4))) /* Hv length */ str = str !! '(' !! hvlen !! ')' End Else If (hvtype = 480) ! (hvtype = 481) Then Do /* FLOAT type */ str = 'FLOAT' hvlen = X2D(C2X(SUBSTR(dbrmentry,hvindex+11,4))) /* Hv length */ If (hvlen = 4) Then /* Single precision floating point */ str = str !! ' (SINGLE PRECISION)' Else If (hvlen = 8) Then /* Double precision floating point */ str = str !! ' (DOUBLE PRECISION)' End Else If (hvtype = 484) ! (hvtype = 485) Then Do /* DECIMAL type */ precision = X2D(C2X(SUBSTR(dbrmentry,hvindex+7,2))) /* Precision */ scale = X2D(C2X(SUBSTR(dbrmentry,hvindex+9,2))) /* Scale */ str = 'DECIMAL(' !! precision !! ',' !! scale !! ')' End Else If (hvtype = 492) ! (hvtype = 493) Then Do /* BIGINT type */ str = 'BIGINT' End Else If (hvtype = 496) ! (hvtype = 497) Then Do /* INTEGER type */ str = 'INTEGER' End Else If (hvtype = 500) ! (hvtype = 501) Then Do /* SMALLINT type */ str = 'SMALLINT' End Else If (hvtype = 988) ! (hvtype = 989) Then Do /* XML type */ str = 'XML' End Else str = 'UNKNOWN' Return str FormatOutput: Parse Arg str count = count + 1 lineout.count = str Return WriteAndBrowseOutput: prefx = Sysvar(SYSPREF) If prefx = '' Then prefx = Userid() Else If prefx <> Userid() Then prefx = prefx!!'.'!!Userid() outdsn = prefx !! '.DBRMMAP.T' !! Time('S') x = Msg('OFF') "DEL '"outdsn"'" /* Assume no SQL > 4000 char's; else, need new lrecl for ALLOC */ "ALLOC FI(OUTDATA) DA('"outdsn"') NEW CYLINDER ", "SPACE(1 1) CATALOG RECFM(V B) LRECL(4092) BLKSIZE(32760)" "EXECIO * DISKW OUTDATA (FINIS STEM LINEOUT." Address ISPEXEC "CONTROL ERRORS RETURN" "BROWSE DATASET('"outdsn"')" Address TSO "FREE FI(OUTDATA)" "DEL '"outdsn"'" Return /*--------------------------------------------------------------------*/ /* Following procedures used to calculate timestamp from CONTOKEN. */ /* They were taken from DBRMTS.REXX - originally written on 92/09/10 */ /* by Brian Kavanagh, then updated by Terry Doner, Axel Zuber and */ /* Peter Wirfs. */ /* http://www.ruban.de/DB2_UDB_for_z_OS/z_OS_Code/z_os_code.html */ /*--------------------------------------------------------------------*/ TimeStamp: procedure; arg ts if ts = '0E5F2F3F00404040' ! ts = '0E5F2F3F01404040' then tod = '0001-01-01-00.00.00.00' else do /*trace intermediates */ /* numeric digits 30 */ /* w1 = left(ts,8) */ /* w2 = right(ts,8) */ /* w2 = sll(w2,3) */ /* tod = #tod(sldl(w1!!w2,3)) */ /*trace off */ end /* amendment by Peter Wirfs, 2006-08-7 */ select when left(ts,1) = "0" then, do parse var ts 2 byte1to4half +7, 10 byte4halfto7 tod = x2c(byte1to4half!!byte4halfto7) end otherwise numeric digits 30 w1 = left(ts,8) w2 = right(ts,8) w2 = sll(w2,3) tod = #tod(sldl(w1!!w2,3)) "(UTC/GMT)" end return tod sll: Procedure; arg w,x return B2X(right(X2B(w)!!copies('0',x),32)) sldl: Procedure; arg dw,x return B2X(right(X2B(dw)!!copies('0',x),64)) srd: Procedure; arg dw,x return B2X(left(copies('0',x)!!X2B(dw),64)) /*******************************************/ #tod: Procedure; arg tod numeric digits 20 msecs = X2D(srd(tod,12)) secs = msecs % 1000000 msecs = msecs - 1000000 * secs days = secs % 86400 secs = secs - 86400 * days hours = secs % 3600 secs = secs - 3600 * hours minutes = secs % 60 secs = secs - 60 * minutes xhours = right('00'hours,2) xminutes = right('00'minutes,2) xsecs = right('00'secs,2) xms = right('000000'msecs,6) xtime = xhours'.'xminutes'.'xsecs'.'xms xdate = jd2cal(cal2jd(1900 01 01)+days) parse var xdate years month days xdate = right('0000'years,4) !!'-'!!, right('00'month,2) !!'-'!!, right('00'days,2) return xdate!!"-"!!xtime /*******************************************/ jd2cal: procedure arg jd julian_calendar a=trunc((jd/36524.25)-51.12264) b=jd+1+a-a%4+1524 c=trunc((b/365.25)-0.3343) d=trunc(365.25*c) e=(b-d)%30.61 d=b-d-trunc(30.61*e) m=e-1 y=c-4716 if e>13.5 then m=m-12 if m<2.5 then y=y+1 return right("0000"y,4) right("00"m,2) right("00"d,2) /*******************************************/ cal2jd: procedure arg yyyy mm dd jd=367*yyyy+275*mm%9-((mm+9)%12+yyyy)*7%4+dd+1721029, -((yyyy+(mm-9)%7)%100+1)*3%4 return jd