* Last processed by NICE on 12-Jun-2000 15:51:00
* Customized for :  IEEE, LINUX, UNIX, MOTIF, F77
      PROGRAM RGBTOPS
C----------------------------------------------------------------------
C GILDAS	Patch to get a postscript truecolor file from 3 pixel
C     images (obtained for example using command SAVE in OVERLAY)
C G.DUVERT, 10-Dec-1992
C----------------------------------------------------------------------
      INCLUDE 'inc:xpar.inc'
      INCLUDE 'inc:ypar.inc'
      INCLUDE 'inc:zpar.inc'
      INCLUDE 'inc:format.inc'
      INCLUDE 'inc:errcod.inc'
      INCLUDE 'inc:memory.inc'
*
      CHARACTER*80 NAMEX,NAMEY,NAMEZ
      CHARACTER*256 NAME,FILE,MESSAGE
      LOGICAL ERROR
      INTEGER N, LENC, SIC_GETLUN, IER, OLUN, NN, SIC_GETVM
      REAL NLEV
      INTEGER*4 IPX, IPY, IPZ, POINTER, IPBX, IPBY, IPBZ, ADDR
      INTEGER*4 BLC(4), TRC(4)
      DATA BLC /4*0/, TRC /4*0/
*
      CALL GILDAS_OPEN
      CALL GILDAS_CHAR('X_NAME$',NAMEX)
      CALL GILDAS_CHAR('Y_NAME$',NAMEY)
      CALL GILDAS_CHAR('Z_NAME$',NAMEZ)
      CALL GILDAS_CHAR('PSFILNAME$',FILE)
      CALL GILDAS_CLOSE
*
      N = LENC(NAMEZ)
      IF (N.EQ.0) GOTO 100
      CALL SIC_PARSEF(NAMEZ,Z_FILE,' ','.gdf')
      CALL GDF_GEIS (Z_ISLO,ERROR)
      IF (.NOT.ERROR) CALL GDF_REIS
     $(Z_ISLO,Z_TYPE,Z_FILE,Z_FORM,Z_SIZE,ERROR)
      IF (ERROR) THEN
         CALL GAGOUT('F-COMBINE,  Cannot read input file')
         GOTO 100
      ENDIF
!      IF (Z_FORM.NE.FMT_BY) THEN
!         CALL GAGOUT('E-TRUERGB,  Only byte images supported')
!         STOP
!      ENDIF
      Z_EXTR = 10
      CALL GDF_RHSEC(Z_ISLO,'EXTREMA',Z_RMIN,Z_EXTR,ERROR)
      IF (Z_EXTR.EQ.0.OR.(Z_RMAX-Z_RMIN).EQ.0.E0) THEN
         CALL GAGOUT('E-FLASH,  Extrema not available')
         STOP
!      ELSEIF (Z_RMIN.LT.0.0 .OR. Z_RMAX.GT.255.0) THEN
!         WRITE (NAME,'(A,1X,1PG13.6,1X,1PG13.6)')
!     $   'E-FLASH,  Extrema invalid ',Z_RMIN,Z_RMAX
!         CALL GAGOUT(NAME)
!         STOP
      ENDIF
      NLEV=Z_RMAX
      CALL GDF_READZ(Z_ISLO,ERROR)
*
      N = LENC(NAMEY)
      IF (N.EQ.0) GOTO 100
      CALL SIC_PARSEF(NAMEY,Y_FILE,' ','.gdf')
      CALL GDF_GEIS (Y_ISLO,ERROR)
      IF (.NOT.ERROR) CALL
     $GDF_REIS (Y_ISLO,Y_TYPE,Y_FILE,Y_FORM,Y_SIZE,ERROR)
      IF (ERROR) THEN
         CALL GAGOUT('F-COMBINE,  Cannot read input file')
         GOTO 100
      ENDIF
!      IF (Y_FORM.NE.FMT_BY) THEN
!         CALL GAGOUT('E-TRUERGB,  Only byte images supported')
!         STOP
!      ENDIF
      Y_EXTR = 10
      CALL GDF_RHSEC(Y_ISLO,'EXTREMA',Y_RMIN,Y_EXTR,ERROR)
      IF (Y_EXTR.EQ.0.OR.(Y_RMAX-Y_RMIN).EQ.0.E0) THEN
         CALL GAGOUT('E-FLASH,  Extrema not availables')
         STOP
!      ELSEIF (Y_RMIN.LT.0.0 .OR. Y_RMAX.GT.255.0) THEN
!         WRITE (NAME,'(A,1X,1PG13.6,1X,1PG13.6)')
!     $   'E-FLASH,  Extrema invalid ',Y_RMIN,Y_RMAX
!         CALL GAGOUT(NAME)
!         STOP
      ENDIF
      NLEV=MAX(NLEV,Y_RMAX)
      CALL GDF_READY(Y_ISLO,ERROR)
*
      N = LENC(NAMEX)
      IF (N.EQ.0) GOTO 100
      CALL SIC_PARSEF(NAMEX,X_FILE,' ','.gdf')
      CALL GDF_GEIS (X_ISLO,ERROR)
      IF (.NOT.ERROR) CALL
     $GDF_REIS (X_ISLO,X_TYPE,X_FILE,X_FORM,X_SIZE,ERROR)
      IF (ERROR) THEN
         CALL GAGOUT('F-COMBINE,  Cannot read input file')
         GOTO 100
      ENDIF
!      IF (X_FORM.NE.FMT_BY) THEN
!         CALL GAGOUT('E-TRUERGB,  Only byte images supported')
!         STOP
!      ENDIF
      X_EXTR = 10
      CALL GDF_RHSEC(X_ISLO,'EXTREMA',X_RMIN,X_EXTR,ERROR)
      IF (X_EXTR.EQ.0.OR.(X_RMAX-X_RMIN).EQ.0.E0) THEN
         CALL GAGOUT('E-FLASH,  Extrema not availables')
         STOP
!      ELSEIF (X_RMIN.LT.0.0 .OR. X_RMAX.GT.255.0) THEN
!         WRITE (NAME,'(A,1X,1PG13.6,1X,1PG13.6)')
!     $   'E-FLASH,  Extrema invalid ',X_RMIN,X_RMAX
!         CALL GAGOUT(NAME)
!         STOP
      ENDIF
      NLEV=MAX(NLEV,X_RMAX)
      N=NLEV
      CALL GDF_READX(X_ISLO,ERROR)
*
      CALL GDF_GEMS (X_MSLO,X_ISLO,BLC,TRC,X_ADDR,X_FORM,ERROR)
      IF (ERROR) GOTO 100
      CALL GDF_GEMS (Y_MSLO,Y_ISLO,BLC,TRC,Y_ADDR,Y_FORM,ERROR)
      IF (ERROR) GOTO 100
      CALL GDF_GEMS (Z_MSLO,Z_ISLO,BLC,TRC,Z_ADDR,Z_FORM,ERROR)
      IF (ERROR) GOTO 100
      IPX = POINTER(X_ADDR,MEMORY)
      IPY = POINTER(Y_ADDR,MEMORY)
      IPZ = POINTER(Z_ADDR,MEMORY)
      IER = SIC_GETLUN (OLUN)
      NAME = FILE
      CALL SIC_PARSEF (NAME,FILE,' ','.ps')
C
C Convert to BYTE
C
      NN = X_DIM(1)*X_DIM(2)
      IF (SIC_GETVM (3*NN,ADDR).NE.1) GOTO 100
      IPBX =  POINTER(ADDR,MEMORY)
      IPBY =  POINTER(ADDR,MEMORY)+NN
      IPBZ =  POINTER(ADDR,MEMORY)+NN
      IF (X_FORM.EQ.FMT_R4) THEN
         CALL CVR4BY(MEMORY(IPX),MEMORY(IPBX),NN,X_RMIN,X_RMAX)
         N = 255
      ELSEIF (X_FORM.EQ.FMT_BY) THEN
         CALL BYTOBY(MEMORY(IPX),MEMORY(IPBX),NN)
      ELSE
         CALL GAGOUT('F-RGBTOPS, unsupported format for X image')
      ENDIF
      IF (Y_FORM.EQ.FMT_R4) THEN
         CALL CVR4BY(MEMORY(IPY),MEMORY(IPBY),NN,Y_RMIN,Y_RMAX)
         N = 255
      ELSEIF (Y_FORM.EQ.FMT_BY) THEN
         CALL BYTOBY(MEMORY(IPY),MEMORY(IPBY),NN)
      ELSE
         CALL GAGOUT('F-RGBTOPS, unsupported format for Y image')
      ENDIF
      IF (Z_FORM.EQ.FMT_R4) THEN
         CALL CVR4BY(MEMORY(IPZ),MEMORY(IPBZ),NN,Z_RMIN,Z_RMAX)
         N = 255
      ELSEIF (Z_FORM.EQ.FMT_BY) THEN
         CALL BYTOBY(MEMORY(IPZ),MEMORY(IPBZ),NN)
      ELSE
         CALL GAGOUT('F-RGBTOPS, unsupported format for Z image')
      ENDIF
C+VMS
c      OPEN (UNIT=OLUN,STATUS='NEW',FILE=FILE,IOSTAT=IER,
c     $CARRIAGECONTROL='LIST',MAXREC=128,RECORDTYPE='STREAM_LF')
C-VMS
C+UNIX
      OPEN (UNIT=OLUN,STATUS='NEW',FILE=FILE,IOSTAT=IER)
C-UNIX
      IF (IER.NE.0) THEN
         MESSAGE='F-OVERLAY,  Cannot open '//FILE(1:LENC(FILE))
         CALL GAGOUT(MESSAGE)
         CALL PUTIOS('E-OVERLAY,  ',IER)
         CALL SIC_FRELUN(OLUN)
         STOP
      ENDIF
*
      CALL GAGOUT('I-OVERLAY,  Writing Preamble on PS file...')
      CALL RGBPREAMBLE(OLUN,X_DIM(1),X_DIM(2),N)
*
      CALL GAGOUT('I-OVERLAY,  Writing MAP on PS file...')
*
      CALL RGB001(MEMORY(IPX),MEMORY(IPY),MEMORY(IPZ),X_DIM(1),
     $X_DIM(2),N,OLUN)
*
* Update disk files and free memory
      CALL GDF_FRIS(X_ISLO,ERROR)
      CALL GDF_FRIS(Y_ISLO,ERROR)
      CALL GDF_FRIS(Z_ISLO,ERROR)
*
      CALL GAGOUT('S-RGB,  Successful completion')
      CALL SYSEXI (1)
*
100   CALL SYSEXI (FATALE)
      END
*<FF>
      SUBROUTINE RGB001(R,G,B,N,M,NLEV,OLUN)
C----------------------------------------------------------------------
      INTEGER N,M,OLUN,NLEV
      INTEGER*1 R(N*M),G(N*M),B(N*M)
*
      INTEGER L,NENREG,NPAD,NRESTE,I
*
      IF (NLEV.LE.16) WRITE (OLUN,'(''/MAXpixval 15 def'')')
      WRITE (OLUN,'('' GAG_TRUECOLOR '')')
      WRITE (OLUN,'('' GAG_Transfer '')')
      IF (NLEV.LE.16) THEN
         WRITE (OLUN,'(I8,1X,I8,'' 4 '')') N, M
      ELSE
         WRITE (OLUN,'(I8,1X,I8,'' 8 '')') N, M
      ENDIF
      WRITE (OLUN,'(''[ '',I8,'' 0 0 '',I8,'' 0 '',I8,'' ]'')')
     $N, -M, M
      WRITE (OLUN,100) 'GAG_TRUECOLOR_Image'
C on n'ecrit que 64 Bytes en Z2 sur 128 caracteres
      IF (NLEV.LE.16) THEN
         NENREG=N*M/128
         NRESTE=N*M-NENREG*128
         DO L=1,NENREG
            WRITE (OLUN,'(128Z1.1)') (R(I),I=((L-1)*128)+1,L*128)
            WRITE (OLUN,'(128Z1.1)') (G(I),I=((L-1)*128)+1,L*128)
            WRITE (OLUN,'(128Z1.1)') (B(I),I=((L-1)*128)+1,L*128)
         ENDDO
         IF(NRESTE.GT.0)  THEN
            NPAD=128-NRESTE
            WRITE (OLUN,'(128Z1.1)')
     $      (R(I),I=NENREG*128+1,NENREG*128+NRESTE),
     $      (0,I=1,NPAD)
            WRITE (OLUN,'(128Z1.1)')
     $      (G(I),I=NENREG*128+1,NENREG*128+NRESTE),
     $      (0,I=1,NPAD)
            WRITE (OLUN,'(128Z1.1)')
     $      (B(I),I=NENREG*128+1,NENREG*128+NRESTE),
     $      (0,I=1,NPAD)
         ENDIF
      ELSE
         NENREG=N*M/64
         NRESTE=N*M-NENREG*64
         DO L=1,NENREG
            WRITE (OLUN,'(64Z2.2)') (R(I),I=((L-1)*64)+1,L*64)
            WRITE (OLUN,'(64Z2.2)') (G(I),I=((L-1)*64)+1,L*64)
            WRITE (OLUN,'(64Z2.2)') (B(I),I=((L-1)*64)+1,L*64)
         ENDDO
         IF(NRESTE.GT.0)  THEN
            NPAD=64-NRESTE
            WRITE (OLUN,'(64Z2.2)')
     $      (R(I),I=NENREG*64+1,NENREG*64+NRESTE),
     $      (0,I=1,NPAD)
            WRITE (OLUN,'(64Z2.2)')
     $      (G(I),I=NENREG*64+1,NENREG*64+NRESTE),
     $      (0,I=1,NPAD)
            WRITE (OLUN,'(64Z2.2)')
     $      (B(I),I=NENREG*64+1,NENREG*64+NRESTE),
     $      (0,I=1,NPAD)
         ENDIF
      ENDIF
      WRITE (OLUN,100) 'grestore'
      WRITE (OLUN,100) '%end(plot)'
      WRITE (OLUN,100) '%%Trailer'
      WRITE (OLUN,100) 'showpage'
      CLOSE (OLUN)
100   FORMAT(A)
      END
*<FF>
      SUBROUTINE RGBPREAMBLE(OLUN,L,M,NLEV)
C----------------------------------------------------------------------
C OVERLAY internal routine.
C Writes the PostScript Header
C Arguments
C	OLUN	I	Logical unit of output file
C----------------------------------------------------------------------
      INTEGER OLUN,L,M,NLEV
* Local
      CHARACTER LADATE*20
      LOGICAL ERROR
      CHARACTER*255 LINE
      CHARACTER*80 FICH,NAME
      INTEGER I,IER,PSLUN,LENC,SIC_GETLUN
      REAL ASPECT
*
* The following line is required for "Standard PostScript"
      WRITE (OLUN,100) '%!PS-Adobe-1.0'
      WRITE (OLUN,100) '%%Creator: OVERLAY 3.0  G.DUVERT 9 Dec 1992'
      WRITE (OLUN,100) '%%Title: Overlay GreG Metacode '//
     $'+ GILDAS Frame on PostScript driver, color extensions '
      CALL SIC_DATE (LADATE)
      WRITE (OLUN,100) '%%CreationDate: '//LADATE
      WRITE (OLUN,100) '%%Pages: 1'
      WRITE (OLUN,100) '%%DocumentsFonts: none'
      WRITE (OLUN, '(A,4(1X,F6.2))')  '%%BoundingBox: ',
     $0.0,0.0,565.0,800.0
*
* This shift is inserted to take care of hardware margins of the
* printer. It is ignored when the plot is inserted in a TEX output
* (through DVIALW), since it is located BEFORE begin(plot)
      WRITE (OLUN,1001) 30.0,30.0
1001  FORMAT (' ',F8.3,' ',F8.3,' translate ')
      WRITE (OLUN,100) '%%EndComments'
      WRITE (OLUN,100) '%begin(plot)'
* Now add the comman lines defined in GAG_PS_HEADER
*
      IER = SIC_GETLUN (PSLUN)
      FICH = 'GAG_PS_HEADER'
      NAME = FICH
      CALL SIC_PARSEF (NAME,FICH,' ','.ps')
      OPEN (UNIT=PSLUN,FILE=FICH(1:LENC(FICH)),
     $STATUS='OLD',FORM='FORMATTED',IOSTAT=IER)
      IF (IER.NE.0) THEN
         LINE='F-OVERLAY,  Cannot open '//FICH(1:LENC(FICH))
         CALL GAGOUT(LINE)
         CALL PUTIOS('E-OVERLAY,  ',IER)
         CALL SIC_FRELUN (PSLUN)
         ERROR = .TRUE.
         RETURN
      ENDIF
      DO WHILE (.TRUE.)
         READ(PSLUN,100,END=1234) LINE
         WRITE(OLUN,100) LINE(1:LENC(LINE))
      ENDDO
1234  CALL SIC_FRELUN (PSLUN)
      CLOSE(UNIT=PSLUN)
* This two comment lines are a patch for a bug in DVIALW. They are neede
* for correct insertion of plots within a TEX page.
* Pens
      WRITE (OLUN,'(''/LUTsize '',I3,'' def'')') NLEV+1
      WRITE (OLUN,100) '/Red LUTsize array def'
      WRITE (OLUN,100) '/Green LUTsize array def'
      WRITE (OLUN,100) '/Blue LUTsize array def'
* Colors
      WRITE (OLUN,'(18(F6.4,1X))') (FLOAT(I)/FLOAT(NLEV),I=0,NLEV)
      WRITE (OLUN,100) 'Red astore pop'
      WRITE (OLUN,'(18(F6.4,1X))') (FLOAT(I)/FLOAT(NLEV),I=0,NLEV)
      WRITE (OLUN,100) 'Green astore pop'
      WRITE (OLUN,'(18(F6.4,1X))') (FLOAT(I)/FLOAT(NLEV),I=0,NLEV)
      WRITE (OLUN,100) 'Blue astore pop'
      WRITE (OLUN,100)
* End Colors
* Initialize coordinates conversion
      ASPECT=FLOAT(M)/FLOAT(L)
      IF (ASPECT.LT.0.6785714) THEN
         WRITE (OLUN, '(A)') '538.0 0.0 moveto 90 rotate '
         WRITE (OLUN, '(2(1X,F10.6),A)') 794.0, 794.0*ASPECT,' scale'
      ELSE
         WRITE (OLUN, '(2(1X,F10.6),A)') 538.0, 538.0*ASPECT ,' scale'
      ENDIF
      WRITE (OLUN,100) 'gsave '
      WRITE (OLUN,100) '%%EndProlog'
      WRITE (OLUN,100) '%%Page: 0 1'
*
100   FORMAT(A)
      END
*
      SUBROUTINE CVR4BY(R,B,N,RMIN,RMAX)
C-----------------------------------------------------------------------
C rescale into a Byte scale
C-----------------------------------------------------------------------
C Global:
C Dummy:
      INTEGER N
      REAL*4 R(N), RMIN, RMAX
      INTEGER*1 B(N)
C Local:
      INTEGER I
      REAL BSCAL
C-----------------------------------------------------------------------
      BSCAL = (RMAX - RMIN) / 256
      IF (BSCAL.EQ.0) RETURN
      DO I=1, N
         B(I) = (R(I)-RMIN)/BSCAL
      ENDDO
      RETURN
      END
