	PROGRAM SEND
C
C
C***************************************************************C
C								C
C								C
C	   reseau interne TELEMECANIQUE VNET niveau 6 		C
C	   ******************************************		C
C								C
C								C
C	module : RECEPTION SUR VAX/VMS DE FICHIERS EN 		C
C		 PROVENANCE D'UN OUTIL DE DEVELOPPEMENT		C
C								C
C		necessite VMS 4.0 au moins			C
C								C
C								C
C								C
C	V2.0 5 decembre 1984	T.DUQUESNAY (DRD Meylan)	C
C	V2.1 6 mars 1985	T.D				C
C	V2.2 13 juin 1985	T.D				C
C								C
C***************************************************************C
C
C
C la version V2 peut dialoguer avec une station INTEL serie III-II
C				    une station INTEL MDS 800
C				    une station ZILOG MCZ
C				    une station INTEL 86-310 sous RMX-86
C
C nouveautes V2.0 par rapport a V1.1 
C		modification de la longueur du nom de fichier
C		nouveau parametre : /E=nom_fichier_VAX
C
C V2.1 correction dans OPEN (TEXT) pour RECL=127 trop petit
C
C V2.2 adaptation a VMS V4.0 (surtout pour IONET6)
C
C
	INCLUDE 'PARAMV6.INC/LIST'
C++
	COMMON /BUFNET/OUVERT,BUFICH,CPTFIC
	LOGICAL*1 OUVERT
	BYTE BUFICH(1024)
	INTEGER*2 CPTFIC
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,COMMANDE,
     1		       LGMAX,LONG
	LOGICAL*1 OUVLOG,COMMANDE(LONG_NETV6)
	INTEGER*4 FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL
	INTEGER*4 LGMAX
	INTEGER*2 LONG
C--
C++	
	COMMON /ANALYSE/OK,TEXT,SPOOL,KEEP,LONG_NFICH,NFICH
	LOGICAL*1 OK,TEXT,SPOOL,KEEP
	INTEGER LONG_NFICH
	BYTE NFICH(LONG_NETV6)
C--
C
C
	BYTE ACK,NAK,STX,EOT,DLE,SOH
	LOGICAL*1 FIN
C
	BYTE BCC
	INTEGER*2 I,NBINCID
	INTEGER*4 ERREUR,J
C
C   type des fonctions
	INTEGER*4 RANTXT,RANOBJ,DERNIER
C
C
C  caracteres de controle de la transmission
	DATA ACK/06/
	DATA NAK/21/
	DATA STX/02/
	DATA EOT/04/
	DATA SOH/01/
	DATA DLE/16/
C--
C
C
Cbegin
C+++++
C
C  initialisations
C
	CALL ERRSNS (FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL)
	LONG = 0
	OUVERT = .FALSE.
	OUVLOG = .FALSE.
	CPTFIC = 0
C
	CALL INITIO
C
C
C  emission START et attente de la reponse contenant le nom de fichier
C
	BUFOUT(1) = SOH
	LGMAX = LONG_NETV6
	CALL DIALOGUE (LGMAX,1)
	DO I=1,LONG_NETV6
C	 sauvegarde en cas d'erreur pour impression
	    COMMANDE(I) = BUFIN(I)
	END DO
C
C  analyse reponse
C
	CALL ANALYSE_CDE (BUFIN)
C
C	traitement erreur eventuelle dans la commande
	IF (.NOT.OK) CALL ERRFAT (4,0)
C
C	verification presence du nom de fichier
	IF (LONG_NFICH .LE. 1) CALL ERRFAT(4,0)
	IF (LONG_NFICH .GT. LONG_NETV6) CALL ERRFAT (4,0)
C
C	insertion d'un caractere nul pour indiquer la fin du
C	 nom du fichier dans NAME
	NFICH(LONG_NFICH) = 0
C
C   ouverture du fichier
C
	IF (TEXT) THEN
		OPEN (UNIT=2,FILE=NFICH,ACCESS='SEQUENTIAL',
CV2.1 1	 	 CARRIAGECONTROL='LIST',RECL=127,STATUS='NEW',
     1	 	 CARRIAGECONTROL='LIST',RECORDTYPE='VARIABLE',STATUS='NEW',
     2		 DEFAULTFILE='.',ERR=299,IOSTAT=ERREUR)
	ELSE
		OPEN (UNIT=2,FILE=NFICH,ACCESS='SEQUENTIAL',
     1		 CARRIAGECONTROL='NONE',RECL=512,STATUS='NEW',
     2		 RECORDTYPE='VARIABLE',DEFAULTFILE='.',
     3		 ERR=299,IOSTAT=ERREUR)
	END IF
	IF (ERREUR .NE. 0) THEN
	    CALL ERRFAT (5,ERREUR)
	ELSE
	    OUVERT=.TRUE.
	END IF
C
C   reception du fichier
C
	FIN = .FALSE.
	DO WHILE (.NOT.FIN)
C
C	  emission accuse reception et attente bloc suivant
C
	    NBINCID = 0
	    BUFOUT(1) = ACK
C
130	    CONTINUE
	    LGMAX = 130
	    CALL DIALOGUE (LGMAX,1)
C
C	  analyse buffer recu
C
	    IF (BUFIN(1).EQ.DLE) THEN 
C		interruption transmission provoquee par l'outil
		BUFOUT(1) = ACK
		CALL EMIS(1)
		CLOSE (2,DISPOSE='DELETE')
		CALL FINIO
		CALL EXIT
C
	    ELSE
		IF (BUFIN(1).EQ.EOT) THEN
		    FIN = .TRUE.
		ELSE
		    IF (BUFIN(1).NE.STX) CALL ERRFAT(8,0)
		END IF
	    END IF
C
C	  verification longueur du buffer recu
	    LONG = BUFIN(2)
	    IF (LONG.GT.LGMAX) THEN
		NBINCID = NBINCID+1
		CALL INCIDE (3,NBINCID)
		IF (NBINCID.GT.4) CALL ERRFAT(9,0)
		BUFOUT(1) = NAK
		GOTO 130
	    END IF
C
C	  verification du BCC
	    BCC = 0
	    DO I = 1,LONG
		BCC = BCC .XOR. BUFIN(I+2)
	    END DO
	    IF (BCC.NE.BUFIN(LONG+3)) THEN
		NBINCID = NBINCID + 1
		CALL INCIDE (4,NBINCID)
		IF (NBINCID.GT.4) CALL ERRFAT(10,0)
		BUFOUT(1) = NAK
		GOTO 130
	    END IF
C
C	  ecriture bloc sur disque
	    IF (TEXT) THEN
		ERREUR = RANTXT (BUFIN(3),LONG)
	    ELSE
		ERREUR = RANOBJ (BUFIN(3),LONG)
	    END IF
	    IF (ERREUR .NE.0) CALL ERRFAT(11,ERREUR)
C
	END DO
C
C
C   envoi accuse reception final
	BUFOUT(1) = ACK
	CALL EMIS(1)
C
C   fermeture fichier
	IF (.NOT.TEXT) THEN
C		vide le buffer tampon
	    ERREUR = DERNIER (BUFIN,0)
C		ferme le fichier
	    CLOSE (2,DISPOSE='SAVE',ERR=399,IOSTAT=ERREUR)
	ELSE
C	 fichier texte : ferme en fonction des switch : /SP /SK
	    IF (SPOOL) THEN
		IF (KEEP) THEN
		    CLOSE (2,DISPOSE='PRINT',ERR=399,IOSTAT=ERREUR)
		ELSE
		    CLOSE (2,DISPOSE='PRINT/DELETE',ERR=399,
     1				IOSTAT=ERREUR)
		END IF
	    ELSE
		CLOSE (2,DISPOSE='SAVE',ERR=399,IOSTAT=ERREUR)
	    END IF
	END IF
C
C   fin
	CALL FINIO
	CALL EXIT
	STOP
C
C
299	CONTINUE
	CALL ERRFAT (12,ERREUR)
	STOP
C
399	CONTINUE
	CALL ERRFAT (13,ERREUR)
	STOP
C
	END
C
C
	SUBROUTINE INCIDE (N1,N2)
C	-------------------------
C
	INTEGER*2 N1,N2
C
	INCLUDE 'PARAMV6.INC/LIST'
C++
	COMMON /ERRLOG/OUVLOG,FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL,COMMANDE,
     1		       LGMAX,LONG
	LOGICAL*1 OUVLOG,COMMANDE(LONG_NETV6)
	INTEGER*4 FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL
	INTEGER*4 LGMAX
	INTEGER*2 LONG
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--
	BYTE DAT(9),TIM(8)
	INTEGER K
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,LGMAX,LONG,
     1			(STATUS(K),K=1,4)
1000	FORMAT(/1X,9A1,1X,8A1,' incident transmission SEND V2.2',I2,1X,I6,
     1	    /,5X,'LGMAX =',I4,3X,'LONG (recue)=',I4,
     2      3X,'IOSB(1:4) =',4(1X,I6))
	RETURN
C
399	CONTINUE
	RETURN
C
	END
C
C
	SUBROUTINE ERRFAT (N1,N2)
C	------------------------
C
C
	INTEGER*2 N1
	INTEGER*4 N2
C
	INCLUDE 'PARAMV6.INC/LIST'
C++
	COMMON /BUFNET/OUVERT,BUFICH,CPTFIC
	LOGICAL*1 OUVERT
	BYTE BUFICH(1024)
	INTEGER*2 CPTFIC
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,COMMANDE,
     1		       LGMAX
	LOGICAL*1 OUVLOG,COMMANDE(LONG_NETV6)
	INTEGER*4 FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL
	INTEGER*4 LGMAX
C--
C++	
	COMMON /ANALYSE/OK,TEXT,SPOOL,KEEP,LONG_NFICH,NFICH
	LOGICAL*1 OK,TEXT,SPOOL,KEEP
	INTEGER LONG_NFICH
	BYTE NFICH(LONG_NETV6)
C--
C
	EXTERNAL SYS$GETMSG
	BYTE DAT(9),TIM(8)
	LOGICAL*1 DLE
	CHARACTER MESSAGE*256
	EQUIVALENCE (BUFOUT(1),MESSAGE(1:1))
	INTEGER*4 MSGLEN,ERROR
	INTEGER K
C
	DATA DLE/16/
C
C
C  interruption de la transmission
C
	CALL ERRSNS (FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL)
	BUFOUT(1) = DLE
	CALL EMIS (1)
	IF (OUVERT) CLOSE (2,DISPOSE='DELETE')
	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 SEND V2.2   ',
     1		'numero : ',I2)
	GOTO (101,102,102,104,105,106,107,108,109,109,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) LGMAX,(STATUS(K),K=1,4)
1202	FORMAT (10X,'erreur SYS$QIOW emission message, attente reponse',
     1		/,5X,'LGMAX =',I9,3X,'IOSB(1:4) =',4(1X,I6))
	GOTO 170
104	CONTINUE
	WRITE (3,1204) (COMMANDE(K),K=1,LONG_NETV6)
1204	FORMAT (10X,'erreur de syntaxe dans la commande',
     1          /3X,'Commande : ',100A1)
	GOTO 180
105	CONTINUE
	WRITE (3,1205) (NFICH(K),K=1,LONG_NFICH)
1205	FORMAT (10X,'erreur sur OPEN',/,3X,'Nom fichier : ',100A1)
	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,'caractere d''entete ni STX,ni EOT,ni DLE !')
	GOTO 180
109	CONTINUE
	WRITE (3,1209)
1209	FORMAT (10X,'nombre d''incidents de transmission trop grand')
	GOTO 180
111	CONTINUE
	WRITE (3,1211)
1211	FORMAT (10X,'erreur ecriture 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
C
C
	INTEGER*4 FUNCTION RANOBJ (BUFFER,LONG)
C	---------------------------------------
C
	BYTE BUFFER(134)
	INTEGER*2 LONG
C
	PARAMETER LGRECORD=510
C
	COMMON /BUFNET/OUVERT,BUFICH,CPTFIC
	LOGICAL*1 OUVERT
	BYTE BUFICH(1024)
	INTEGER*2 CPTFIC
C
	INTEGER*4 DERNIER
C
	INTEGER*4 ERREUR
	INTEGER*2 I,J
C
C
	ERREUR = 0
	I = 0
C
	DO WHILE (I.LT.LONG)
	    I = I + 1
	    CPTFIC = CPTFIC + 1
	    BUFICH(CPTFIC) = BUFFER(I)
	    IF (CPTFIC .EQ. LGRECORD) THEN
		WRITE(2,100,IOSTAT=ERREUR,ERR=99)(BUFICH(J),J=1,LGRECORD)
100		FORMAT (1024A1)
		CPTFIC = 0
	    END IF
	END DO
C
99	CONTINUE
	RANOBJ = ERREUR
	RETURN
C
C
	ENTRY DERNIER (BUFFER,LONG)
C	---------------------------
C
	ERREUR = 0
	IF (CPTFIC.NE.0) THEN
	    WRITE (2,100,IOSTAT=ERREUR) (BUFICH(J),J=1,CPTFIC)
	END IF
	DERNIER = ERREUR
	RETURN
C
	END
C
C
	INTEGER*4 FUNCTION RANTXT (BUFFER,LONG)
C	---------------------------------------
C
	BYTE BUFFER(134)
	INTEGER*2 LONG
C
	COMMON /BUFNET/OUVERT,BUFICH,CPTFIC
	LOGICAL*1 OUVERT
	BYTE BUFICH(1024)
	INTEGER*2 CPTFIC
C
	INTEGER*4 ERREUR
	INTEGER*2 I,J
C
C
	ERREUR = 0
	I = 1
C
	DO WHILE (I.LE.LONG)
C
	    IF ((CPTFIC.NE.0).OR.(BUFFER(I).NE.10)) THEN
C		(on elimine les LF apres RC)
C
		IF (BUFFER(I).EQ.13) THEN
C		  ecriture dans le fichier
		    WRITE(2,100,IOSTAT=ERREUR,ERR=99)(BUFICH(J),J=1,CPTFIC)
100		    FORMAT (1024A1)
		    CPTFIC = 0
		ELSE
		    CPTFIC = CPTFIC + 1
		    BUFICH(CPTFIC) = BUFFER(I)
		END IF
C
	    END IF
C
	    I = I + 1
C
	END DO
C
99	CONTINUE
	RANTXT = ERREUR
	RETURN
C
	END
