      PROGRAM COLOR
C-----------------------------------------------------------------------
C! converts python color maps to OFM
C# Utility
C-----------------------------------------------------------------------
C;  Copyright (C) 2025
C;  Associated Universities, Inc. Washington DC, USA.
C;
C;  This program is free software; you can redistribute it and/or
C;  modify it under the terms of the GNU General Public License as
C;  published by the Free Software Foundation; either version 2 of
C;  the License, or (at your option) any later version.
C;
C;  This program is distributed in the hope that it will be useful,
C;  but WITHOUT ANY WARRANTY; without even the implied warranty of
C;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C;  GNU General Public License for more details.
C;
C;  You should have received a copy of the GNU General Public
C;  License along with this program; if not, write to the Free
C;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   Program to extract a colormap from the python definition.
C      A logical or enviroment variable named MYDIR must be defined
C   before running COLOR.
C   The output will be written to a file named name.000 and will
C   be of OFM format (j : B G R) where the python ones are R G B one
C   line per value.  The python have 256 values (none zero), the OFM
C   have j=0 as 0, j=1-2045 interpolating the python values.
C-----------------------------------------------------------------------
      INTEGER   MAXTYP, NGNU
      PARAMETER (MAXTYP = 100)
      PARAMETER (NGNU = 23)
C
      CHARACTER INLINE*100, OUTLIN*100, INFIL*48, OUTFIL*48,
     *   NAME(MAXTYP)*10, GPLBRK(2)*35, GPLDAT*16, GPLTXT(2,NGNU)*35,
     *   GPLTX1(2,10)*35, GPLTX2(2,10)*35, GPLTX3(2,NGNU-20)*35
      INTEGER   I, J, JTRIM, INAME, LUNO, LUNI, NNAMES, IRET, JV,
     *   IB, IG, IR, FINDI, FINDO, K, KBP, KBPLIM, LUTOUT, IDATE(3)
      LOGICAL   REVERS
      REAL      X, V
      DOUBLE PRECISION RV(2048), GV(2048), BV(2048)
      EQUIVALENCE (GPLTXT(1,1), GPLTX1(1,1))
      EQUIVALENCE (GPLTXT(1,11), GPLTX2(1,1))
      EQUIVALENCE (GPLTXT(1,21), GPLTX3(1,1))
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA LUNI, LUNO /3, 11/
      DATA GPLDAT /'  Copyright (C) '/
      DATA GPLBRK /'-----------------------------------',
     *             '-----------------------------------'/
      DATA GPLTX1 /'  Associated Universities, Inc. Was',
     *             'hington DC, USA.                   ',
     *             '                                   ',
     *             '                                   ',
     *             '  This program is free software; yo',
     *             'u can redistribute it and/or       ',
     *             '  modify it under the terms of the ',
     *             'GNU General Public License as      ',
     *             '  published by the Free Software Fo',
     *             'undation; either version 2 of      ',
     *             '  the License, or (at your option) ',
     *             'any later version.                 ',
     *             '                                   ',
     *             '                                   ',
     *             '  This program is distributed in th',
     *             'e hope that it will be useful,     ',
     *             '  but WITHOUT ANY WARRANTY; without',
     *             ' even the implied warranty of      ',
     *             '  MERCHANTABILITY or FITNESS FOR A ',
     *             'PARTICULAR PURPOSE.  See the       '/
      DATA GPLTX2 /'  GNU General Public License for mo',
     *             're details.                        ',
     *             '                                   ',
     *             '                                   ',
     *             '  You should have received a copy o',
     *             'f the GNU General Public           ',
     *             '  License along with this program; ',
     *             'if not, write to the Free          ',
     *             '  Software Foundation, Inc., 675 Ma',
     *             'ssachusetts Ave, Cambridge,        ',
     *             '  MA 02139, USA.                   ',
     *             '                                   ',
     *             '                                   ',
     *             '                                   ',
     *             '  Correspondence concerning AIPS sh',
     *             'ould be addressed as follows:      ',
     *             '         Internet email: aipsmail@n',
     *             'rao.edu.                           ',
     *             '         Postal address: AIPS Proje',
     *             'ct Office                          '/
      DATA GPLTX3 /'                         National R',
     *             'adio Astronomy Observatory         ',
     *             '                         520 Edgemo',
     *             'nt Road                            ',
     *             '                         Charlottes',
     *             'ville, VA 22903-2475 USA           '/
C-----------------------------------------------------------------------
C                                       AIPS system start up stuff
      TSKNAM ='COLOR'
      NPOPS = 1
      MSGKIL = 32000
      MSGSUP = 32000
      LUTOUT = 2045
      CALL ZDCHIN (.FALSE.)
      MSGKIL = 32000
C                                       Get list of routines
      INFIL = 'MYDIR:LIST.COLOR'
      CALL ZTXOPN ('READ', LUNI, FINDI, INFIL, .FALSE., IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING LIST OF NAMES'
         GO TO 990
         END IF
      NNAMES = 0
C                                       Get names
      DO 20 I = 1,MAXTYP
         CALL ZTXIO ('READ', LUNI, FINDI, INLINE, IRET)
         IF (IRET.EQ.2) THEN
            IRET = 0
            GO TO 30
         ELSE IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING LIST.COLOR'
            GO TO 990
            END IF
         IF ((INLINE(:1).NE.';') .AND. (INLINE(:1).NE.'#')) THEN
            NNAMES = NNAMES + 1
            J = JTRIM (INLINE)
            NAME(NNAMES) = INLINE(:J)
            END IF
 20      CONTINUE
 30   CALL ZTXCLS (LUNI, FINDI, IRET)
C                                       loop over types
      DO 100 INAME = 1,NNAMES
         IF (NAME(INAME)(:1).EQ.'#') GO TO 100
         REVERS = NAME(INAME)(:1).EQ.'-'
         IF (REVERS) THEN
            INFIL = NAME(INAME)(2:)
            NAME(INAME) = INFIL
            END IF
         J = JTRIM (NAME(INAME))
         INFIL = 'MYDIR:' // NAME(INAME)(:J) // '.py'
         CALL ZTXOPN ('READ', LUNI, FINDI, INFIL, .FALSE., IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPENING PYTHON FILE'
            GO TO 990
            END IF
         CALL CHLORU('UP', J, NAME(INAME))
         OUTFIL = 'MYDIR:' // NAME(INAME)(:J) // '.000'
         CALL ZTXOPN ('WRIT', LUNO, FINDO, OUTFIL, .FALSE., IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPENING OFM FILE WRITE'
            GO TO 990
            END IF
         CALL ZTXIO ('READ', LUNI, FINDI, INLINE, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING FIRST LINE OF PY FILE'
            GO TO 990
            END IF
         OUTLIN = ';;  ' // NAME(INAME)
         J = JTRIM (OUTLIN)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING FIRST LINES OF OFM FILE'
            GO TO 990
            END IF
         OUTLIN = ';;' // GPLBRK(1) // GPLBRK(2)
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNO, FINDO, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING GPL'
            GO TO 990
            END IF
         CALL ZDATE (IDATE)
         IF (IDATE(1).LT.200) IDATE(1) = IDATE(1) + 1900
         WRITE (OUTLIN,1300) GPLDAT, IDATE(1)
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNO, FINDO, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING GPL'
            GO TO 990
            END IF
         DO 310 I = 1,NGNU
            OUTLIN = ';;' // GPLTXT(1,I) // GPLTXT(2,I)
            J = JTRIM (OUTLIN)
            CALL ZTXIO ('WRIT', LUNO, FINDO, OUTLIN(:J), IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITING GPL'
               GO TO 990
               END IF
 310        CONTINUE
         OUTLIN = ';;' // GPLBRK(1) // GPLBRK(2)
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNO, FINDO, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING GPL'
            GO TO 990
            END IF
         OUTLIN = ';; AUTHORS: ' // INLINE
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNO, FINDO, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING FIRST LINE OF OFM FILE'
            GO TO 990
            END IF
C                                       read the python data
         CALL ZTXIO ('READ', LUNI, FINDI, INLINE, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING 2ND LINE OF PY FILE'
            GO TO 990
            END IF
         JV = 1
         KBPLIM = JTRIM (INLINE)
         KBP = INDEX (INLINE, '[[') + 2
         CALL GETNUM (INLINE, KBPLIM, KBP, RV(JV))
         CALL GETNUM (INLINE, KBPLIM, KBP, GV(JV))
         CALL GETNUM (INLINE, KBPLIM, KBP, BV(JV))
         DO 40 JV = 2,1024
            CALL ZTXIO ('READ', LUNI, FINDI, INLINE, IRET)
            IF (IRET.EQ.2) THEN
               IRET = 0
               GO TO 50
            ELSE IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING A LINE OF PY FILE'
               GO TO 990
               END IF
            KBPLIM = INDEX (INLINE, ']') - 1
            KBP = INDEX (INLINE, '[') + 1
            CALL GETNUM (INLINE, KBPLIM, KBP, RV(JV))
            CALL GETNUM (INLINE, KBPLIM, KBP, GV(JV))
            CALL GETNUM (INLINE, KBPLIM, KBP, BV(JV))
            RV(JV) = RV(JV) ** 2.2
            GV(JV) = GV(JV) ** 2.2
            BV(JV) = BV(JV) ** 2.2
 40         CONTINUE
C                                       write the OFM
 50      CALL ZTXCLS (LUNI, FINDI, IRET)
         JV = JV - 1
         write (msgtxt,1150) name(iname), jv
         call msgwrt (4)
 1150    format ('File ',A,' read',I6,' rows')
         WRITE (OUTLIN,1050) 0, 0, 0, 0
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNO, FINDO, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING 2ND LINE OF OFM FILE'
            GO TO 990
            END IF
         DO 90 I = 1,LUTOUT
            IF (REVERS) THEN
               X = (LUTOUT-I) / (LUTOUT-1.0) * (JV-1.0) + 1.0
            ELSE
               X = (I-1.0) / (LUTOUT-1.0) * (JV-1.0) + 1.0
               END IF
            K = X + 0.0001
            IF (K.EQ.JV) K = K - 1
            V = RV(K) + (RV(K+1)-RV(K)) * (X-K)
            IR = 10000 * V + 0.5
            V = GV(K) + (GV(K+1)-GV(K)) * (X-K)
            IG = 10000 * V + 0.5
            V = BV(K) + (BV(K+1)-BV(K)) * (X-K)
            IB = 10000 * V + 0.5
            WRITE (OUTLIN,1050) I, IB, IG, IR
            CALL ZTXIO ('WRIT', LUNO, FINDO, OUTLIN(:J), IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITING OFM FILE'
               GO TO 990
               END IF
 90         CONTINUE
         CALL ZTXCLS (LUNO, FINDO, IRET)
 100  CONTINUE
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  STOP
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR',I4,' ON ',A)
 1050 FORMAT (I4,' :',3I6)
 1300 FORMAT (';;',A,I4)
      END

