	PROGRAM OAD5
C
C
C***********************************************************************C
C									C
C									C
C		reseau NET V5.2 interne TELEMECANIQUE			C
C		*************************************			C
C									C
C									C
C	module : EMISSION SOUS VAX/VMS DE FICHIERS OBJETS		C
C		 EXECUTABLES A DESTINATION D'UNE MAQUETTE 		C
C									C
C		necessite au moins VMS 4.x				C
C									C
C									C
C	V1.0 31 janvier 1984	T.DUQUESNAY (DRD Meylan)		C
C	V1.2 septembre 1984	T.D.					C
C	V1.3 18 mars 1985	T.D.					C
C	V1.4 18 avril 1985	T.D.					C
C	V1.5 23 juillet 1985	T.D.					C
C									C
C***********************************************************************C
C
C d'apres tache OAD sous RSX-11M
C
C    principale adaptation : sous VMS les BYTE ou LOGICAL*1 sont signes,
C	il faut donc faire tres attention aux rangements INTEGER -> BYTE
C
C V1.2 explicitation de certains messages d'erreurs
C
C V1.3 corrections mineures et OPEN en READONLY
C
C V1.4 corrections sur calcul BCC dans EMLDA
C
C V1.5 adaptation a VMS V4.0
C
C
C
C++
	COMMON /BUFNET/BUFICH,CPTFIC,LONGLU,LART,IART,FINOBJ
	LOGICAL*1 FINOBJ
	BYTE BUFICH(1024)
	INTEGER*2 CPTFIC,LONGLU,LART,IART
C--
C++
	COMMON /IO/CHAN,IFUNC1,IFUNC2,BUFIN,BUFOUT,STATUS,BUFCHAR
	INTEGER*2 CHAN,STATUS(4)
	INTEGER*4 IFUNC1,IFUNC2,BUFCHAR(3)
	BYTE BUFIN(134),BUFOUT(256)
C--
C++
	COMMON /ERRLOG/OUVLOG,FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL,NAME,NLONG
	LOGICAL*1 OUVLOG,NAME(80)
	INTEGER*4 FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL
	INTEGER*2 NLONG
C--
C++
	COMMON /LDA/ILDA,BUFLDA
	BYTE BUFLDA(128)
	INTEGER*2 ILDA
C--
C
	LOGICAL*1 FIN,TROUVE
	LOGICAL*1 SYMB,LOAD
	REAL ADR
	INTEGER*2 I,J,K,NBINCID,IJK
	BYTE C,L,ICOD
	BYTE TNOM(80),ZNOM(80)
	INTEGER*2 TMOD(5)
	INTEGER*4 ERREUR
C
C   type des fonctions
	INTEGER*2 ICAROBJ
	BYTE CAROBJ
C
C   codes speciaux pour la transmission (special G.CANY)
	BYTE ACK,ENQ,EOT,NAK,STX,DLE,SOH
	DATA ACK/06/
	DATA NAK/21/
	DATA STX/02/
	DATA EOT/04/
	DATA ENQ/05/
	DATA SOH/01/
	DATA DLE/16/
C
	BYTE LDACH,LDAAS,LDADL,LDANM,LDAC1
	DATA LDAC1/1/
	DATA LDACH/0/
	DATA LDADS/1/
	DATA LDADL/2/
	DATA LDANM/3/
C
	BYTE CODNOM,CODSL,CODLIG,CODFIN,CODCHA,CODDEB,CODPUB
	DATA CODFIN/14/
	DATA CODCHA/6/
	DATA CODPUB/22/
	DATA CODDEB/2/
	DATA CODNOM/16/
	DATA CODSL/18/
	DATA CODLIG/8/
C
C
C++
C
C
C	 ENTREES / SORTIES
C	-------------------
C
C  un canal est demande par SYS$ASSIGN pour la ligne de transmission
C    sur l'unite logique 'TT'
C
C  le canal 2(FORTRAN) est utilise pour le disque utilisateur
C
C  le canal 3(FORTRAN) est utilise pour le fichier erreur
C
C--
C
Cbegin
C+++++
C
C   initialisations
C
	CALL ERRSNS (FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL)
	FIN = .FALSE.
C
	CALL INITIO
C
	LONGC = 80
C
C   emission START et attente de la reponse contenant le nom de fichier
C
	BUFOUT(1) = SOH
	CALL DIALOGUE (LONGC,1)
	DO I = 1,LONGC
	    NAME(I) = BUFIN(I)
	END DO
C
C   analyse de la reponse
C
	NLONG = LONGC
	IMOD = 1
	NBREMOD = 0
	LOAD = .TRUE.
	SYMB = .FALSE.
	TROUVE = .FALSE.
	I = 1
	DO WHILE ((I .LE. LONGC).AND. (NAME(I) .NE. 0))
	    IF (NAME(I).EQ.13) THEN
		NAME(I) = 0
	    END IF
	    IF (NAME(I).EQ. '(' ) THEN
		LOAD = .FALSE.
		SYMB = .TRUE.
		NAME(I) = 0
		J = I + 1
		II = I
	    END IF
	    I = I + 1
	END DO
	NLONG = I - 1
	IF (.NOT.SYMB) GOTO 100
C
030	NBREMOD = NBREMOD + 1
	TMOD(NBREMOD) = IMOD
040	C = NAME(J)
	J = J + 1
	IF (C.EQ.0) THEN
	    NAME(I) = '('
	    CALL ERRFAT (10,0)
	END IF
	TNOM(IMOD) = C
	IMOD = IMOD + 1
	IF (C.EQ. ',' ) GOTO 030
	IF (C.EQ. ')' ) GOTO 100
	GOTO 040
100	CONTINUE
C
C   ouverture du fichier
C
	OPEN (UNIT=2,FILE=NAME,ACCESS='SEQUENTIAL',STATUS='OLD',
     1	      READONLY,DEFAULTFILE='.',ERR=2999,IOSTAT=ERREUR)
	IF (ERREUR .NE. 0) THEN
	    IF (SYMB) NAME(II) = '('
	    CALL ERRFAT (5,ERREUR)
	ELSE
C	     lecture du premier enregistrement du fichier ouvert pour
C	     verifier son etat.
	    READ (2,10120,END=902,ERR=2997,IOSTAT=ERREUR)
     1             LONGLU,(BUFICH(I),I=1,LONGLU)
C	     emission ack
	    BUFOUT(1) = ACK
	    CALL EMIS (1)
	END IF
C
C   il peut y avoir 2 types de fichiers
C	1 ) fichier deja en codage LDA
C	2 ) fichier en codage INTEL a transmettre en LDA
C
	IF (BUFICH(1) .EQ. CODDEB) GOTO 150
	IF (BUFICH(1) .NE. LDA1) THEN
C	     codage inconnu
	    ERREUR = BUFICH(1)
	    IF (SYMB) NAME(II) = '('
	    CALL ERRFAT (4,ERREUR)
	END IF
C
C	traitement fichier code en LDA
C
	DO I = 1,LONGLU
	    BUFOUT(I) = BUFICH(I)
	END DO
	NBCAR = LONGLU
C
	FIN = .FALSE.
	DO WHILE (.NOT.FIN)
C
C	 emission du buffer
C
	    NBINCID = 0
121	    CONTINUE 
	    CALL DIALOGUE (1,NBCAR)
C
C        analyse de la reponse
C
	    IF (BUFIN(1) .NE. ACK) THEN
		IF (BUFIN(1) .EQ. NAK) THEN
C		    incident de transmission
		    NBINCID = NBINCID + 1
		    CALL INCIDE (1,NBINCID)
		    GOTO 121
		ELSE
		    ERREUR = BUFIN(1)
		    CALL ERRFAT (8,ERREUR)
		END IF
	    END IF
C
C            lecture enregistrement suivant
C
	    READ (2,10120,END=2996,ERR=2997,IOSTAT=ERREUR)
     1		   NBCAR,(BUFOUT(I),I=1,NBCAR)
10120	    FORMAT (Q,1024A1)
C
	END DO
C
C    emission dernier bloc
C
2996	CONTINUE
	BUFOUT(1) = EOT
	CALL EMIS (130)
C
	CLOSE (2,ERR=3999,IOSTAT=ERREUR)
C
	CALL FINIO
	CALL EXIT
	STOP
C
2997	CONTINUE
	CALL ERRFAT(11,ERREUR)
	STOP
C
902	CONTINUE
	CALL ERRFAT (9,0)	!FICHIER VIDE
	STOP
C
C
C TRAITEMENT FICHIERS ABSOLUS MDS
C
150	CONTINUE
	CPTFIC = 1
160	CONTINUE
	ICOD = CAROBJ()
	LART = ICAROBJ()
	LART = (ICAROBJ()*256) + LART
	IART = 1
	FINOBJ = .FALSE.
C
C AIGUILLAGE EN FONCTION DU TYPE ARTICLE LU
C
	IF (ICOD.EQ.CODFIN) GOTO 700
	IF ((ICOD.EQ.CODCHA).AND.LOAD) GOTO 180
	IF ((ICOD.EQ.CODPUB).AND.LOAD) GOTO 300
	IF ((ICOD.EQ.CODNOM).AND.SYMB) GOTO 400
	IF ((ICOD.EQ.CODSL).AND.SYMB.AND.TROUVE) GOTO 300
	IF ((ICOD.EQ.CODLIG).AND.SYMB.AND.TROUVE) GOTO 500
C
C ARTICLE A IGNORER
C
162	CONTINUE
	DO I=1,LART
	    C = CAROBJ()
	END DO
	GOTO 160
C
C ARTICLE DE CHARGEMENT
C
C     SKIP OCTET DANS ARTICLE ISIS
C
180	C=CAROBJ()
	BUFLDA(1)=SOH
	BUFLDA(2)=LDACH
C
C     LIRE ADRESSE IMPLANTATION DANS ISIS
C
	ADR=ICAROBJ()
	ADR=(ICAROBJ()*256.)+ADR
200	CONTINUE
	IJK = AMOD(ADR,256.)
	IJK = IJK .AND. 255
	IF (IJK .GT. 128) THEN
	    BUFLDA(5) = (-IJK) .AND. 255
	    BUFLDA(5) = -BUFLDA(5)
	ELSE
	    IF (IJK .EQ. 128) THEN
		BUFLDA(5) = -128
	    ELSE
	    	BUFLDA(5) = IJK
	    END IF
	END IF
	IJK = (ADR-AMOD(ADR,256.))/256.
	IJK = IJK .AND. 255
	IF (IJK .GT. 128) THEN
	    BUFLDA(6) = (-IJK) .AND. 255
	    BUFLDA(6) = -BUFLDA(6)
	ELSE
	    IF (IJK .EQ. 128) THEN
		BUFLDA(6) = -128
	    ELSE
	        BUFLDA(6) = IJK
	    END IF
	END IF
	ILDA=7
205	C=CAROBJ()
	BUFLDA(ILDA)=C
	ILDA=ILDA+1
	ADR=ADR+1
	IF ((ILDA.LT.127).AND.(.NOT.FINOBJ)) GOTO 205
	CALL EMLDA
230	IF (.NOT.FINOBJ) GOTO 200
	C=CAROBJ()
	GOTO 160
C
C ARTICLE DECLARATION DE SYMBOLES
C
300	CONTINUE
	BUFLDA(1)=SOH
	BUFLDA(2)=LDADS
	BUFLDA(5)=0
	BUFLDA(6)=0
	C=CAROBJ()
304	ILDA=7
305	BUFLDA(ILDA)=CAROBJ()
	BUFLDA(ILDA+1)=CAROBJ()
	ILDA=ILDA+2
	L=CAROBJ()
	BUFLDA(ILDA)=L
	ILDA=ILDA+1
	DO I=1,L+1
	    BUFLDA(ILDA)=CAROBJ()
	    ILDA=ILDA+1
	END DO
	IF ((ILDA.LT.90).AND.(.NOT.FINOBJ)) GOTO 305
	CALL EMLDA
	IF (.NOT.FINOBJ) GOTO 304
	C=CAROBJ()
	GOTO 160
C
C ARTICLE DECLARATION NOM DE MODULE
C
400	CONTINUE
	L = CAROBJ()
	DO I=1,L
	    ZNOM(I)=CAROBJ()
	END DO
	DO WHILE (.NOT.FINOBJ)
	    C = CAROBJ()
	END DO
	C=CAROBJ()
C
C     RECHERCHE DU NOM DANS LA LISTE
C
	TROUVE=.FALSE.
	DO 430 I=1,NBREMOD
	J=TMOD(I)
	K=1
420	IF (ZNOM(K).NE.TNOM(J)) GOTO 430
	K=K+1
	J=J+1
	IF (K.NE.L+1) GOTO 420
	IF (TNOM(J).NE.',' .AND. TNOM(J).NE.')') GOTO 430
	TROUVE=.TRUE.
430	CONTINUE
C
	IF (TROUVE) THEN
	    BUFLDA(1)=SOH
	    BUFLDA(2)=LDANM
	    BUFLDA(5)=L
	    ILDA=6
	    DO I=1,L
		BUFLDA(ILDA)=ZNOM(I)
		ILDA=ILDA+1
	    END DO
	    CALL EMLDA
	END IF
	GOTO 160
C
C ARTICLE DECLARATION DE LIGNE
C
500	CONTINUE
	C=CAROBJ()
510	BUFLDA(1)=SOH
	BUFLDA(2)=LDADL
	BUFLDA(5)=0
	BUFLDA(6)=0
	ILDA=7
520	DO I=1,4
	    BUFLDA(ILDA) = CAROBJ()
	    ILDA=ILDA+1
	END DO
	IF ((ILDA.LT.120).AND.(.NOT.FINOBJ)) GOTO 520
	CALL EMLDA
	IF (.NOT.FINOBJ) GOTO 510
	C=CAROBJ()
	GOTO 160
C
C FIN DE TRAITEMENT
C
700	CONTINUE
	BUFOUT(1) = EOT
	CALL EMIS (130)
C
	CLOSE (2,ERR=3999,IOSTAT=ERREUR)
C
	CALL EXIT
	CALL FINIO
	STOP

C
2999	CONTINUE
	CALL ERRFAT (12,ERREUR) 
	STOP
C
3999	CONTINUE
	CALL ERRFAT (13,ERREUR)
	STOP
C
	END
C
C
C
	BYTE FUNCTION CAROBJ
C
C   lecture d'un octet dans le fichier object
C
C++
	COMMON /BUFNET/BUFICH,CPTFIC,LONGLU,LART,IART,FINOBJ
	LOGICAL*1 FINOBJ
	BYTE BUFICH(1024)
	INTEGER*2 CPTFIC,LONGLU,LART,IART
C--
	INTEGER*2 I
	INTEGER*4 ERREUR
C
	IF (CPTFIC.GT.LONGLU) THEN
	    READ(2,900,ERR=901,IOSTAT=ERREUR)
     1		  LONGLU,(BUFICH(I),I=1,LONGLU)
900	    FORMAT(Q,1024A1)
	    CPTFIC=1
	END IF
	CAROBJ=BUFICH(CPTFIC)
	CPTFIC = CPTFIC + 1
	IART=IART+1
	IF (IART.EQ.LART) FINOBJ=.TRUE.
	RETURN
C
901	CONTINUE
	CALL ERRFAT(11,ERREUR)
	STOP
	END
C
C
	INTEGER*2 FUNCTION ICAROBJ
C
C   lecture valeur entiere positive dans le fichier object
C
	BYTE CAROBJ
	INTEGER*2 I
C
	I=CAROBJ()
	IF (I.LT.0) I=256+I
	ICAROBJ=I
	RETURN
	END
C
C
C
C
C
	SUBROUTINE EMLDA
C
C	EMISSION ARTICLE FORMAT LDA
C
C++
	COMMON /LDA/ILDA,BUFLDA
	BYTE BUFLDA(128)
	INTEGER*2 ILDA
C--
C++
	COMMON /IO/CHAN,IFUNC1,IFUNC2,BUFIN,BUFOUT,STATUS,BUFCHAR
	INTEGER*2 CHAN,STATUS(4)
	INTEGER*4 IFUNC1,IFUNC2,BUFCHAR(3)
	BYTE BUFIN(134),BUFOUT(256)
C--
C
	INTEGER*2 NBINCID,I
	BYTE ACK,NAK
	INTEGER*2 BCC
	INTEGER*4 ERREUR
C
	DATA ACK/06/
	DATA NAK/21/
C
	BUFLDA(3)=ILDA-1
	BUFLDA(4)=0
C
C  calcul du bcc
	BCC = 0
	DO I=1,ILDA-1
	    BCC = (BCC + BUFLDA(I)) .AND. 255
	END DO
	IF (BCC .GT. 128) THEN
	    BUFLDA(ILDA) = (-BCC) .AND. 255
	ELSE
	    IF (BCC .EQ. 128) THEN
		BUFLDA(ILDA) = -128
	    ELSE
	    	BUFLDA(ILDA) = BCC
		BUFLDA(ILDA) = -BUFLDA(ILDA)
	    END IF
	END IF
C
C  emission buffer et attente reponse
	NBINCID = 0
	DO I=1,128
	    BUFOUT(I) = BUFLDA(I)
	END DO
C
200	CONTINUE
	CALL DIALOGUE (1,130)
C
	IF (BUFIN(1) .NE. ACK) THEN
	    IF (BUFIN(1) .EQ. NAK) THEN
		NBINCID = NBINCID + 1
		CALL INCIDE(1,NBINCID)
		GOTO 200
	    ELSE
		ERREUR = BUFIN(1)
		CALL ERRFAT (8,ERREUR)
	    END IF
	END IF
C
	END
	SUBROUTINE INCIDE (N1,N2)
C
C
	INTEGER*2 N1,N2
C++
	COMMON /ERRLOG/OUVLOG,FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL,NAME,NLONG
	LOGICAL*1 OUVLOG,NAME(80)
	INTEGER*4 FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL
	INTEGER*2 NLONG
C--	
C++
	COMMON /IO/CHAN,IFUNC1,IFUNC2,BUFIN,BUFOUT,STATUS,BUFCHAR
	INTEGER*2 CHAN,STATUS(4)
	INTEGER*4 IFUNC1,IFUNC2,BUFCHAR(3)
	BYTE BUFIN(134),BUFOUT(256)
C--
	INTEGER*2 K
	BYTE DAT(9),TIM(8)
C
	IF (.NOT.OUVLOG) THEN
	    OPEN (UNIT=3,FILE='ERREURNET.LOG',ACCESS='APPEND',
     1		STATUS='UNKNOWN',ERR=399)
	    OUVLOG = .TRUE.
	END IF
C
	CALL DATE (DAT)
	CALL TIME (TIM)
	WRITE (3,1000) (DAT(K),K=1,9),(TIM(K),K=1,8),N1,N2,
     1			(STATUS(K),K=1,4)
1000	FORMAT(/1X,9A1,2X,8A1,'  incident transmission OAD5 ',I2,1X,I6,
     1	    /,5X,I6,3X,'IOSB(1:4) =',4(1X,I6))
	RETURN
C
399	CONTINUE
	RETURN
C
	END

	SUBROUTINE ERRFAT (N1,N2)
C
C
	INTEGER*2 N1
	INTEGER*4 N2
C
C++
	COMMON /BUFNET/BUFICH,CPTFIC,LONGLU,LART,IART,FINOBJ
	LOGICAL*1 FINOBJ
	BYTE BUFICH(1024)
	INTEGER*2 CPTFIC,LONGLU,LART,IART
C--
C++
	COMMON /IO/CHAN,IFUNC1,IFUNC2,BUFIN,BUFOUT,STATUS,BUFCHAR
	INTEGER*2 CHAN,STATUS(4)
	INTEGER*4 IFUNC1,IFUNC2,BUFCHAR(3)
	BYTE BUFIN(134),BUFOUT(256)
C--
C++
	COMMON /ERRLOG/OUVLOG,FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL,NAME,NLONG
	LOGICAL*1 OUVLOG,NAME(80)
	INTEGER*4 FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL
	INTEGER*2 NLONG
C--
C
	EXTERNAL SYS$GETMSG
	INTEGER*2 K
	BYTE DAT(9),TIM(8)
	BYTE DLE
	INTEGER*4 ERROR,MSGLEN
	CHARACTER MESSAGE*256
C
	DATA DLE/16/
C
C
C  interruption de la transmission
C
	CALL ERRSNS (FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL)
	BUFOUT(1) = DLE
	CALL EMIS (130)
	GOTO 500
C
C
	ENTRY ERRFAT2 (N1,N2)
C	---------------------
C
	CALL ERRSNS (FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL)
C
500	CONTINUE
C
C  rangement information (numero d'erreur)
C 
	IF (.NOT.OUVLOG) THEN
	    OPEN (UNIT=3,FILE='ERREURNET.LOG',ACCESS='APPEND',
     1		STATUS='UNKNOWN',ERR=399)
	    OUVLOG = .TRUE.
	END IF
C
	CALL DATE (DAT)
	CALL TIME (TIM)
	WRITE (3,1000) (DAT(K),K=1,9),(TIM(K),K=1,8),N1
1000	FORMAT (/,1X,9A1,2X,8A1,'  erreur fatale OAD5 V1.5   ',
     1		'numero : ',I2)
	GOTO (101,102,102,104,105,106,107,108,170,110,111,105,113)
     1		N1
C
101	CONTINUE
	WRITE (3,1201)
1201	FORMAT (10X,'erreur rendue par SYS$ASSIGN') 
	GOTO 170
102	CONTINUE
	WRITE (3,1202) (STATUS(K),K=1,4)
1202	FORMAT (10X,'erreur SYS$QIOW emission BUFOUT,attente BUFIN',
     1		/,5X,'IOSB(1:4) =',4(1X,I6))
	GOTO 170
104	CONTINUE
	WRITE (3,1204) (NAME(K),K=1,NLONG)
1204	FORMAT (10X,'fichier binaire en codage inconnu',
     1            /,3X,'Nom fichier : ',80A1)
	GOTO 180
105	CONTINUE
	WRITE (3,1205) (NAME(K),K=1,NLONG)
1205	FORMAT (10X,'erreur sur OPEN',/,3X,'Nom fichier : ',80A1)
	GOTO 170
106	CONTINUE
	WRITE (3,1206)
1206	FORMAT (10X,'erreur SYS$QIOW IO$_SENSEMODE ou IO$_SETMODE')
	GOTO 170
107	CONTINUE
	WRITE (3,1206)
	GOTO 175
108	CONTINUE
	WRITE (3,1208)
1208	FORMAT (10X,'compte rendu ni ACK,ni NAK !')
	GOTO 180
110	CONTINUE
	WRITE (3,1210) (NAME(K),K=1,80)
1210	FORMAT (10X,'erreur parametres nom de module',
     1            /,3X,'Nom fichier : ',80A1)
	GOTO 180
111	CONTINUE
	WRITE (3,1211)
1211	FORMAT (10X,'erreur lecture fichier sur disque')
	GOTO 170
113	CONTINUE
	WRITE (3,1213)
1213	FORMAT (10X,'erreur sur CLOSE')
	GOTO 170
C
175	CONTINUE
	WRITE (3,1006) N2
1006	FORMAT (5X,'IOSB(1) =',I9)
C
170	CONTINUE
	IF (FNUM .NE. 0) THEN
	    ERROR = SYS$GETMSG(%VAL(CONDVAL),%REF(MSGLEN),MESSAGE,%VAL(15),)
	ELSE
	    ERROR = SYS$GETMSG(%VAL(N2),%REF(MSGLEN),MESSAGE,%VAL(15),)
	END IF
	WRITE (3,7070) MESSAGE(1:MSGLEN)
7070	FORMAT (1X,A)
C
178	CONTINUE
	WRITE (3,1002) FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL
1002	FORMAT (5X,'FORTRAN run-time error number :',I9,/,
     1		5X,'RMS completion status code (STS):',I9,/,
     2		5X,'RMS status value (STV):',I9,/,
     3		5X,'logical unit number :',I9,/,
     4	        5X,'actual VAX-11 condition value :',I9)
C
180	CONTINUE
	WRITE (3,1001)
1001	FORMAT (/,1X,20(H-),' reseau interne TELEMECANIQUE DRD Meylan ',
     1		19(H-))
C
399	CONTINUE
	CALL FINIO
	CALL EXIT
	END
