C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.PURPOSE:
C  Take 3 bdf-files and create a PPM raster file.
C
C.VERSION: 1.0          MIDAS-VERSION: 94NOV portable
C
C.LANGUAGE: F77+ESOext+...
C
C.AUTHOR: HJRoeser
C
C.IDENTIFICATION: rgbhjr.for
C
C.KEYWORDS:
C  ???
C
C.ALGORITHM:
C  ???
C
C.INPUT/OUTPUT:
C
C  The following keywords are used:
C
C
C.REVISIONS
C
C               none thus far
C
C.COPYRIGHT: Copyright (c)        1995  MPIA Heidelberg
C                                       all rights reserved
C
C.VERSION
C 090130	integrated in MIDAS 09SEP, KB
C 090210	last modif
C 
C-----------------------------------------------------------------------
C
C
C
      IMPLICIT NONE
C
      INTEGER    STATUS, EX_STAT, ACT_VAL,
     +               naxis1, naxis2, naxis3,
     +               npix1(2), npix2(2), npix3(2),
     +               ncol, nrow, length, lo, n_ima, no_f1, no_f2, no_f3
C
      INTEGER KNULL, KUNIT(1), DNULL, DUNIT(1)
C
C  define pointers for MIDAS
      integer*8 pntr_in,  pntr_in2,  pntr_in3
C
      CHARACTER*18    DATE
      character*48    cunit1, cunit2, cunit3
      character*72    ident1, ident2, ident3
      CHARACTER*80    MESSAGE, frame1, frame2, frame3, output
      CHARACTER*8     KEYWORD
C
      REAL            cutsr(2), cutsg(2), cutsb(2)
C
      LOGICAL         LOG_MODE, NO_R, NO_G, NO_B
C
      DOUBLE PRECISION
     +  start1(2), start2(2), start3(2), step1(2), step2(2), step3(2)
C
      INTEGER      MADRID(1)
C
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
      COMMON    /VMR/ MADRID
C
      DATA  KNULL, KUNIT, DNULL, DUNIT /4*0/
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
C
C  get into MIDAS
      CALL STSPRO('RGBHJR')
C
      CALL STKRDC('P1',1,1,80,ACT_VAL,output, KUNIT, KNULL, STATUS)
      LO = INDEX(OUTPUT,' ') - 1		!was: lo = length(output)
      n_ima = 0
      CALL STKRDC('P3',1,1,80,ACT_VAL,frame1, KUNIT, KNULL, STATUS)
      IF (frame1(1:4) .eq. 'NULL') then
           no_r = .true.
      else
           no_r = .false.
           n_ima = n_ima + 1
      endif
      CALL STKRDC('P4',1,1,80,ACT_VAL,frame2, KUNIT, KNULL, STATUS)
      IF (frame2(1:4) .eq. 'NULL') then
           no_g = .true.
      else
           no_g = .false.
           n_ima = n_ima + 1
      endif
      CALL STKRDC('P5', 1, 1, 80, ACT_VAL, frame3, KUNIT, KNULL, STATUS)
      IF (frame3(1:4) .eq. 'NULL') then
           no_b = .true.
      else
           no_b = .false.
           n_ima = n_ima + 1
      endif
      CALL STKRDR('cutr', 1, 2, ACT_VAL, cutsr, KUNIT, KNULL, STATUS)
      CALL STKRDR('cutg', 1, 2, ACT_VAL, cutsg, KUNIT, KNULL, STATUS)
      CALL STKRDR('cutb', 1, 2, ACT_VAL, cutsb, KUNIT, KNULL, STATUS)
      CALL STKRDC('CTRL_KEY',1,1,4,ACT_VAL,KEYWORD,KUNIT,KNULL,STATUS)
      if ((keyword(1:1) .eq. 'L') .or.
     +    (keyword(1:1) .eq. 'l'))  then
           log_mode = .true.			!LOG scaling
      else
           log_mode = .false.			!RAMP scaling
      endif
C 
      IF (N_IMA .LT. 2) THEN
         MESSAGE = 'we need at least 2 colour components '
         STATUS = 99
         GOTO 9999
      ENDIF
         
C 
      if (.not. no_r) then
         call stiget (frame1, d_r4_format, f_i_mode, f_ima_type, 2,
     +        naxis1, npix1, start1, step1, ident1, cunit1, pntr_in, 
     +        no_f1, status)
      endif
      if (.not. no_g) then
         call stiget (frame2, d_r4_format, f_i_mode, f_ima_type , 2,
     +        naxis2, npix2, start2, step2, ident2, cunit2, pntr_in2, 
     +        no_f2, status)
      endif
      if (.not. no_b) then
         call stiget (frame3, d_r4_format, f_i_mode, f_ima_type , 2,
     +        naxis3, npix3, start3, step3, ident3, cunit3, pntr_in3, 
     +        no_f3, status)
      endif
                     
      if (n_ima .eq. 3)  then
         if (npix1(1) .ne. npix2(1) .or. npix1(1) .ne. npix3(1) .or.
     +       npix1(2) .ne. npix2(2) .or. npix1(2) .ne. npix3(2))  then
            message = 'Unequal dimensions!'
            status = 100
            go to 9999
         endif
         ncol    = npix1(1)
         nrow    = npix1(2)
C 
      else				!only 2 components
         if (no_r)  then
            if (npix2(1) .ne. npix3(1) .or.
     +          npix2(2) .ne. npix3(2)      )  then
               message = 'Unequal dimensions!'
               status = 101
               go to 9999
            endif
            cutsr(1) = (cutsg(1) + cutsb(1)) / 2.
            cutsr(2) = (cutsg(2) + cutsb(2)) / 2.
            ncol    = npix2(1)
            nrow    = npix2(2)
         endif
         if (no_g)  then
            if (npix1(1) .ne. npix3(1) .or.
     +          npix1(2) .ne. npix3(2)      )  then
               message = 'Unequal dimensions!'
               status = 102
               go to 9999
            endif
            cutsg(1) = (cutsr(1) + cutsb(1)) / 2.
            cutsg(2) = (cutsr(2) + cutsb(2)) / 2.
            ncol    = npix1(1)
            nrow    = npix1(2)
         endif
         if (no_b)  then
            if (npix1(1) .ne. npix2(1) .or.
     +          npix1(2) .ne. npix2(2)      )  then
               message = 'Unequal dimensions!'
               status = 103
               go to 9999
            endif
            cutsb(1) = (cutsg(1) + cutsr(1)) / 2.
            cutsb(2) = (cutsg(2) + cutsr(2)) / 2.
            ncol    = npix1(1)
            nrow    = npix1(2)
         endif
      endif


      status = 110
      message = 'Cannot open output file!'
      open (unit=1, file=output(1:lo)//'.ppm', iostat=status, 
     +      status='unknown', err=9999)
      write (1, '("P3"/I6,I6/"255")') ncol, nrow
C 
      call do_it(madrid(pntr_in),madrid(pntr_in2),madrid(pntr_in3),
     +   cutsr,cutsg,cutsb,ncol,nrow,log_mode,no_r,no_g,no_b)

9999  EX_STAT = STATUS
      if (ex_stat .ne. 0)  then
         call sttput (message, status)
         call sttput ('RGB not successful!', status)
      endif
      call stkwri ('outputi', ex_stat, 1, 1, kunit, status)
      call stsepi
      END

      subroutine do_it (redf, greenf, bluef, cutsr, cutsg, cutsb, 
     +                    ncol, nrow, log_mode, no_r, no_g, no_b)
C
      implicit none
C
      integer max_x
      parameter  (max_x = 3 * 8600)		! was:  3 * max_dimx
      integer ncol, nrow, i, j, l, k

      integer*2 buffer(max_x), blue, green, red

      real redf(ncol,nrow), greenf(ncol,nrow), bluef(ncol,nrow),
     +       cutsr(2),cutsg(2),cutsb(2),cutsrl(2),cutsgl(2),cutsbl(2),
     +       help, redr, greenr, bluer, diffr, diffg, diffb

      logical   log_mode, no_r, no_g, no_b
C 
C 
      if (log_mode)  then
           diffr = log10(cutsr(2) - cutsr(1))
           diffg = log10(cutsg(2) - cutsg(1))
           diffb = log10(cutsb(2) - cutsb(1))
      else
           diffr = cutsr(2) - cutsr(1)
           diffg = cutsg(2) - cutsg(1)
           diffb = cutsb(2) - cutsb(1)
      endif

      do j = nrow, 1, -1
           do i = 1, ncol
              if (.not. no_r)  then
                 redr = redf(i,j)
              else
                 redr = (bluef(i,j)+greenf(i,j))/2.
              endif
              redr = min(redr, cutsr(2))
              redr = max(redr, cutsr(1))
              help = max(1.,redr - cutsr(1))
              if (log_mode)  help = log10(help)
              redr = 255. * help / diffr
              red = nint(redr)

              if (.not. no_g)  then
                 greenr = greenf(i,j)
              else
                 greenr = (redf(i,j)+bluef(i,j))/2.
              endif
              greenr = min(greenr, cutsg(2))
              greenr = max(greenr, cutsg(1))
              help = max(1.,greenr - cutsg(1))
              if (log_mode)  help = log10(help)
              greenr = 255. * help / diffg
              green = nint(greenr)

              if (.not. no_b) then
                 bluer = bluef(i,j)
              else
                 bluer = (redf(i,j)+greenf(i,j))/2.
              endif
              bluer = min(bluer, cutsb(2))
              bluer = max(bluer, cutsb(1))
              help = max(1.,bluer - cutsb(1))
              if (log_mode)  help = log10(help)
              bluer = 255. * help / diffb
              blue = nint(bluer)
              
              k = 3*(i-1)
              buffer(k+1) = red
              buffer(k+2) = green
              buffer(k+3) = blue
           enddo    ! i = columns
           
           write (1, '(5(3I4," "))') (buffer(l), l=1,3*ncol)

      enddo       !  j =rows
C
      return
      end
