* * $Id: dzdhtm.F,v 1.1.1.1 1996/03/04 16:13:19 mclareni Exp $ * * $Log: dzdhtm.F,v $ * Revision 1.1.1.1 1996/03/04 16:13:19 mclareni * Dzdoc/Zebpack * * #include "dzdoc/pilot.h" SUBROUTINE DZDHTM(ISTORE,L,CFLAG) * * walk through a d/s at L and write doc in html * CFLAG 'S' one bank only * 'T' bank tree (default) * 'N' no data words * 'P' plain text (no hyperlinks) * C+SEQ,ZUNIT. #include "zebra/zebq.inc" #include "zebra/mzca.inc" #include "zebra/mzcb.inc" C++CDE,ZBCDK. From DZEBRA C++SEQ,DZDPRM C++SEQ,DZDOCC. CHARACTER*(*) CFLAG CHARACTER*16 CLTOP INTEGER L,LN,LGO,LRET,LDOWN, IFC,ILC, IHNONE, LUN PARAMETER (LUN=65) CHARACTER*8 ANCHOR CHARACTER*80 CGET CHARACTER*4 CLINK CHARACTER*5 CSUFFI CHARACTER*16 CLDOWN CHARACTER*16 DZE2US INTEGER KEYVEC(2) *--- CALL MZSDIV(ISTORE,-7) CALL UCTOH('NONE',IHNONE,4,4) IF(INDEX(CFLAG,'P').EQ. 0)THEN CSUFFI='.html' ELSE CSUFFI='.txt' ENDIF WRITE(CLTOP,'(A4,I7.7,A)')IQ(KQS+L-4),L,CSUFFI CLTOP=DZE2US(CLTOP) OPEN(LUN,FILE=CLTOP) * CALL KUOPEN(LUN,CLTOP,'UNKNOWN',IRET) IF(LQ(KQS+L+1).EQ.0)THEN CLTOP=' ' ELSE WRITE(CLTOP,'(A4,I7.7,A)') + IQ(KQS+LQ(KQS+L+1)-4),LQ(KQS+L+1),CSUFFI CLTOP=DZE2US(CLTOP) ENDIF IF(INDEX(CFLAG,'P').EQ. 0)THEN WRITE(LUN,'(A)')'' WRITE(LUN,'(A)')'
' WRITE(LUN,'(A)')'' WRITE(LUN,'(A)')'' ENDIF LRET=-L 20 CONTINUE LGO=LRET CALL DZDWTR(ISTORE,LGO,LRET) IF(LRET.NE.0)THEN * WRITE(*,'(A,A4,I10)')'Found ',IQ(KQS+LRET-4),LRET KEYVEC(1)=IQ(KQS+LRET-4) IF(LQ(KQS+LRET+1).GT.1)THEN KEYVEC(2)=IQ(KQS+LQ(KQS+LRET+1)-4) ELSE KEYVEC(2)=IHNONE ENDIF I1000=100000 LQBKD=0 CALL RZIN(0,LQBKD,2,KEYVEC,I1000,'D') IF (LQBKD .EQ. 0)THEN NLT = 0 NLU = 0 WRITE(*,'(A,A4)')'No doc for bank ',KEYVEC(1) ELSE IP0=KQSP+LQBKD+1 CALL DZDGGI(IQ(IP0),'CL',' ',CGET,IFC,ILC) WRITE(ANCHOR,'(I8.8)')LRET IF(INDEX(CFLAG,'P').EQ. 0) + WRITE(LUN,'(A)')'' IF(ILC.GT.0)WRITE(LUN,'(A)') + 'Bank IDH '//CGET(1:4)//' '//CGET(5:ILC) IF(INDEX(CFLAG,'P').EQ. 0) + WRITE(LUN,'(A)')'' CALL DZDGGI(IQ(IP0),'AU',' ',CGET,IFC,ILC) IF(ILC.GT.0)WRITE(LUN,'(A,A,A)')'Author(s) ',CGET(IFC:ILC) CALL DZDGGI(IQ(IP0),'VE',' ',CGET,IFC,ILC) IF(ILC.GT.0)WRITE(LUN,'(A,A,A)')'Version ',CGET(IFC:ILC) NID=IQ(KQS+LRET-5) WRITE(LUN,'(A,I6)')'NumId ',NID NL=IQ(KQS+LRET-3) NS=IQ(KQS+LRET-2) WRITE(LUN,'(A,I6)')'Str Links ',NS NR=NL-NS WRITE(LUN,'(A,I6)')'Ref Links ',NR ND=IQ(KQS+LRET-1) WRITE(LUN,'(A,I6)')'NData ',ND NIO = JBYT(IQ(KQS+LRET),19,4) IOFFBS = - (NIO + NL + 8 + 1) CALL DZDIOC(IQ(KQS+LRET+IOFFBS),CGET,ILC) IF(ILC.GT.0)WRITE(LUN,'(A,A,A)')'IO-Char ',CGET(1:ILC) WRITE(LUN,'(A)')'---------- System links ----------' CALL UHTOC(KEYVEC(2),4,CLINK,4) IF(CLINK.NE.'NONE')THEN IF(INDEX(CFLAG,'P').EQ. 0)THEN WRITE(ANCHOR,'(I8.8)')LQ(KQS+LRET+1) * is it very first bank IF(LRET.EQ.L)THEN NCH=LNBLNK(CLTOP) WRITE(LUN,'(A,A)')'Up-Link '// + ''// + CLINK//'' ELSE WRITE(LUN,'(A,A)')'Up-Link '// + ''// + CLINK//'' ENDIF ELSE WRITE(LUN,'(A,A)')'Up-Link '//CLINK ENDIF * handle Origin link eventually ELSE WRITE(LUN,'(A,A)')'Up-Link '//CLINK ENDIF LN=LQ(KQS+LRET) IF(LN.NE.0)THEN CALL UHTOC(IQ(KQS+LN-4),4,CLINK,4) IF(INDEX(CFLAG,'P').EQ. 0)THEN WRITE(ANCHOR,'(I8.8)')LN WRITE(LUN,'(A,A)')'Next-Link '// + ''// + CLINK//'' ELSE WRITE(LUN,'(A,A)')'Next-Link '//CLINK ENDIF ENDIF IF(NS.GT.0)THEN WRITE(LUN,'(A)')'--------- Struct links ----------' DO I=1,NS LDOWN=LQ(KQS+LRET-I) IF(LDOWN.NE.0)THEN CALL UHTOC(IQ(KQS+LDOWN-4),4,CLINK,4) CALL DZDGGI(IQ(IP0),'LI',CLINK,CGET,IFC,ILC) IF(INDEX(CFLAG,'P').EQ. 0)THEN WRITE(ANCHOR,'(I8.8)')LDOWN IF(INDEX(CFLAG,'S').NE.0)THEN WRITE(CLDOWN,'(A4,I7.7,A5)') + CLINK,LDOWN,'.html' CLDOWN=DZE2US(CLDOWN) WRITE(LUN,'(I6,A)')I, + ' '// + CLINK//' '//CGET(1:ILC) ELSE WRITE(LUN,'(I6,A)')I, + ' '// + CLINK//' '//CGET(1:ILC) ENDIF ELSE WRITE(LUN,'(I6,A)')I,CLINK//' '//CGET(1:ILC) ENDIF ENDIF ENDDO ENDIF IF(ND.GT.0 .AND. INDEX(CFLAG,'N').EQ. 0)THEN CALL DZDDWD(ISTORE,LRET,' ',1,ND,LUN) ENDIF CALL MZDROP(0,LQBKD,' ') LQBKD=0 ENDIF IF(INDEX(CFLAG,'S').EQ.0)GOTO 20 ENDIF IF(INDEX(CFLAG,'P').EQ. 0)THEN WRITE(LUN,'(A)')'' WRITE(LUN,'(A)')'' WRITE(LUN,'(A)')'' ENDIF 999 CONTINUE RETURN END *******************************************************************