* Last processed by NICE on 12-Jun-2000 15:54:00
* Customized for :  IEEE, LINUX, UNIX, MOTIF, F77
* $Header: /scisoft/gildas/sou/nic/main/nic_main.for,v 1.58 2000/02/25 10:51:21 neri Exp $
* $Log: nic_main.for,v $
* Revision 1.58  2000/02/25 10:51:21  neri
* *** empty log message ***
*
C Revision 1.57  99/03/30  14:27:49  14:27:49  broguier ()
C new sic
C
C Revision 1.55  99/03/12  19:48:55  19:48:55  broguier (Dominique Broguiere)
C use SIC_GTLGTR to interpretate logical names
C
C Revision 1.54  98/02/13  17:01:47  17:01:47  neri
C no exit after multiple definition of bolo-data:
C
C Revision 1.53  98/02/03  22:25:58  22:25:58  broguier (Dominique Broguiere)
C sic_parsef(' ', replaced by sic_parsef(str,
C
C Revision 1.52  98/02/03  10:08:07  10:08:07  neri (Roberto Neri)
C *** empty log message ***
C
C Revision 1.51  98/01/29  04:07:21  04:07:21  broguier (Dominique Broguiere)
C 'sic log bolo_data: "~/'
C
C Revision 1.50  97/03/10  18:32:31  18:32:31  broguier ()
C commentaries
C
C Revision 1.38  96/11/21  11:12:24  11:12:24  neri (Roberto Neri)
C *** empty log message ***
C
C Revision 1.37  96/11/19  23:26:19  23:26:19  broguier (Dominique Broguiere)
C Retrieving FITs
C
C
C Revision 1.27  96/03/19  15:22:15  15:22:15  gildas (Gildas manager)
C replaced CALL EXIT by  CALL SYSEXI(99) which is PORTABLE. GD.
C
C Revision 1.10  95/10/13  09:52:52  09:52:52  broguier (Dominique Broguiere)
C Get old opacities if any
C
C
C Revision 1.6  95/01/12  12:46:52  12:46:52  broguier (Dominique Broguiere)
C removal of subscan shared memory area of s
C
C Revision 1.5  95/01/09  16:47:40  16:47:40  broguier (Dominique Broguiere)
C rsm
C
C
*
*
      PROGRAM NIC_MAIN
      INCLUDE 'nic.inc'
      INCLUDE 'parameter.inc'
      INCLUDE 'par.inc'
      LOGICAL ERROR,EXIST, ESCL, CHECK_OLD_UT, FOUND, FOUND7, FOUND8
      LOGICAL FOUND1, FOUND2, FOUND3, FOUND4, FOUND5, FOUND6
      INTEGER*4 N, IER, SIC_GETVM, POINTER
      INTEGER*4 STATUS, SIC_GET_FOREIGN, SIC_PURGE, LENC
      INTEGER*4 IP_SKYUT, IP_SKYTAU
      INTEGER*4 IP_DUMUT, IP_DUMTAU, WORK1
      CHARACTER COMMAND*80, NAME*40, FILE*80, CHAIN*80, MESFILE*80
      CHARACTER STR*80, FILENAME*80, SKYDIP_LINE*132, BOLO_STR*80
      REAL*8  UT
      REAL*4  TAU
*
C+VMS
c      EXTERNAL GR_HANDLER
C-VMS
*
      STATUS = SIC_GET_FOREIGN(COMMAND,N)
      IF (STATUS.NE.1) CALL SYSEXI (STATUS)
C+VMS
c      CALL LIB$ESTABLISH(GR_HANDLER)
C-VMS
*
      CALL INIT_NIC
*
* Initialize the LOG files
*
      NAME = 'nic'
      CALL SIC_PARSEF (NAME,FILE,'GAG_LOG:','.log')
      STATUS = SIC_PURGE (FILE,1)        ! keep just one version
      IF (STATUS.NE.1) CALL SYSEXI(STATUS)
      CALL SIC_PARSEF (NAME,MESFILE,'GAG_LOG:','.mes')
      STATUS = SIC_PURGE (MESFILE,1)     ! keep just one version
      IF (STATUS.NE.1) CALL SYSEXI(STATUS)
      CALL MESSAGE_INIT(MESFILE,2,0)
*
* Initialize the command monitor
*
      NAME = 'NIC'
      CALL SIC_OPT(NAME,FILE,.TRUE.)
      CALL LOAD_GREG('INTERACTIVE')
      CALL SIC_SETSYMBOL ('INPUT','@ define',ERROR)
      CALL LOAD_VECTOR
      CALL LOAD_TASK
      CALL LOAD_NIC
      CHAIN = 'SIC'//CHAR(92)//'SIC EXTENSION .nic'
      CALL EXEC_NIC (CHAIN)
      BOLO_STR = 'BOLO_DATA:'
      CALL SIC_GTLGTR(BOLO_STR)
      NAME = 'init'
      CALL SIC_PARSEF (NAME,FILE,'GAG_INIT:','.nic')
      INQUIRE (FILE=FILE,EXIST=EXIST)
      IF (.NOT.EXIST) THEN
         OPEN (UNIT=1,FILE=FILE,FORM='formatted',STATUS='new',ERR=200)
         WRITE (1,'(x,a)') '! --- Created by NIC'
         WRITE (1,'(x,a)') '!'
         WRITE (1,'(x,2a)') '! let sic$window no   ',
     $   '         ! let''s have x-widgets (the default)'
         WRITE (1,'(x,2a)') 'input                 ',
     $   '         ! use the standard reduction procedures'
         WRITE (1,'(x,2a)') 'let do_map no   ',
     $   '         ! avoid plotting maps after MAKPLAN, RESTORE,...'
         WRITE (1,'(x,2a)') 'set gain_amplifier on ',
     $   '         ! apply the amplifier gain corrections'
         WRITE (1,'(x,2a)') 'set gain_channel on   ',
     $   '         ! apply the channel gain corrections'
         WRITE (1,'(x,2a)') '! set gain_elevation off',
     $   '       ! by default, no gain elevation corrections'
         WRITE (1,'(x,2a)') 'set opacity on        ',
     $   '         ! correct for the atmospheric opacity'
         WRITE (1,'(x,2a)') 'var * read            ',
     $   '         ! have read access to all NIC variables'
         IF (INDEX(BOLO_STR,'BOLO_DATA:').NE.0) THEN
            WRITE (1,'(x,2a)') 'sic log bolo_data: "~/',
     $      'nmb/"    ! nmb data directory by default  '
         ENDIF
         CLOSE (UNIT=1)
      ELSE
         OPEN (UNIT=1,FILE=FILE,FORM='formatted',STATUS='old',ERR=200)
         FOUND1 = .FALSE.
         FOUND2 = .FALSE.
         FOUND3 = .FALSE.
         FOUND4 = .FALSE.
         FOUND5 = .FALSE.
         FOUND6 = .FALSE.
         FOUND7 = .FALSE.
         FOUND8 = .FALSE.
100      READ (1,'(a)',ERR=150,END=150) STR
         CALL SIC_LOWER (STR)
         IF (INDEX(STR,'gain_a').NE.0) FOUND1 = .TRUE.
         IF (INDEX(STR,'gain_c').NE.0) FOUND2 = .TRUE.
         IF (INDEX(STR,'gain_e').NE.0) FOUND3 = .TRUE.
         IF (INDEX(STR,'opacit').NE.0) FOUND4 = .TRUE.
         IF (INDEX(STR,'var * ').NE.0) FOUND5 = .TRUE.
         IF (INDEX(STR,'sic$wi').NE.0) FOUND6 = .TRUE.
         IF (INDEX(STR,'bolo_d').NE.0) FOUND7 = .TRUE.
         IF (INDEX(STR,'do_map').NE.0) FOUND8 = .TRUE.
         GOTO 100
150      IF (.NOT.(FOUND1.AND.FOUND2.AND.FOUND3.AND.FOUND4.AND.
     $   FOUND5.AND.FOUND6.AND.FOUND8))
     $   WRITE (1,'(x,a)') '! --- Modified by NIC'
         IF (.NOT.FOUND1) WRITE (1,'(x,2a)') 'set gain_amplifier on ',
     $   '         ! apply the amplifier gain corrections'
         IF (.NOT.FOUND2) WRITE (1,'(x,2a)') 'set gain_channel on   ',
     $   '         ! apply the channel gain corrections'
         IF (.NOT.FOUND3) WRITE (1,'(x,2a)') '! set gain_elevation off',
     $   '      ! by default, no gain elevation corrections'
         IF (.NOT.FOUND4) WRITE (1,'(x,2a)') 'set opacity on        ',
     $   '         ! correct for the atmospheric opacity'
         IF (.NOT.FOUND5) WRITE (1,'(x,2a)') 'var * read            ',
     $   '         ! have read access to all NIC variables'
         IF (.NOT.FOUND6) WRITE (1,'(x,2a)') '! let sic$window yes  ',
     $   '        ! let''s have x-widgets (the default)'
         IF (.NOT.FOUND7.AND.INDEX(BOLO_STR,'BOLO_DATA:').NE.0) THEN
            WRITE (1,'(x,a)') '! --- Modified by NIC'
            WRITE (1,'(x,2a)') 'sic log bolo_data: "~/',
     $      'nmb/"    ! nmb data directory by default  '
         ENDIF
         IF (.NOT.FOUND8) WRITE (1,'(x,2a)') 'let do_map no   ',
     $   '         ! avoid plotting maps after MAKPLAN, RESTORE,...'
         CLOSE(UNIT=1)
      ENDIF
      CHAIN = 'SIC'//CHAR(92)//'@ "!'//FILE(1:LENC(FILE))//'"'
      CALL EXEC_NIC(CHAIN)
200   NAME = 'rsm'
      CALL SIC_PARSEF (NAME,STR,'GAG_UTIL:',' ')
      CHAIN = 'sys "!'//STR(1:LENC(STR))//'"'
c     CALL EXEC_NIC(CHAIN)
      CALL SIC_DEF_REAL ('COUNTS_PER_JY',JY_TO_COUNTS,0,1,
     $.FALSE.,ERROR)
*
* Get old opacities if any
*
      FILENAME = 'nic.sky'
*      CALL SIC_LOWER (FILENAME)
      OPEN (UNIT=2,FILE=FILENAME,FORM='formatted',STATUS='old',
     $IOSTAT=IER)
      IF (IER.EQ.0) THEN
*
* Get good skydip scans
*
         WRITE (6,'(a)') 'Retrieving SKYDIPs ...'
         ESCL = .TRUE.
         DO WHILE (ESCL)
            READ (2,'(a)',ERR=98,END=98) SKYDIP_LINE
            IF (INDEX(SKYDIP_LINE,'!').EQ.0) ESCL = .FALSE.
         ENDDO
         NUMBER_OF_SKYDIPS = 0
         DO WHILE (.NOT.ESCL)
            READ (SKYDIP_LINE,*,ERR=97,END=97) UT,TAU
            FOUND = .FALSE.
            IF (NUMBER_OF_SKYDIPS.NE.0) THEN
               FOUND = CHECK_OLD_UT (MEMORY(IP_SKYUT),
     $         NUMBER_OF_SKYDIPS,UT)
               IF (.NOT.FOUND) THEN
                  IER = SIC_GETVM(3*NUMBER_OF_SKYDIPS,WORK1)
                  IF (IER.NE.1) THEN
                     CALL MESSAGE (2,1,'MAIN',
     $               'Memory allocation failure')
                     CALL SYSEXI(99)
                  ENDIF
                  IP_DUMUT = POINTER(WORK1,MEMORY)   ! double precision
                  IP_DUMTAU = IP_DUMUT + 2*NUMBER_OF_SKYDIPS
                  CALL R8TOR8(MEMORY(IP_SKYUT),MEMORY(IP_DUMUT),
     $            NUMBER_OF_SKYDIPS)
                  CALL R4TOR4(MEMORY(IP_SKYTAU),MEMORY(IP_DUMTAU),
     $            NUMBER_OF_SKYDIPS)
                  CALL FREE_VM (3*(NUMBER_OF_SKYDIPS-1),SKYDIP_MEM)
               ENDIF
            ENDIF
            IF (.NOT.FOUND) THEN
               NUMBER_OF_SKYDIPS = NUMBER_OF_SKYDIPS+1
               IER = SIC_GETVM(3*NUMBER_OF_SKYDIPS,SKYDIP_MEM)
               IF (IER.NE.1) THEN
                  CALL MESSAGE (2,1,'MAIN',
     $            'Memory allocation failure')
                  CALL SYSEXI(99)
               ENDIF
               IP_SKYUT = POINTER(SKYDIP_MEM,MEMORY)
               IP_SKYTAU = IP_SKYUT + 2*NUMBER_OF_SKYDIPS  ! double precision
               IF (NUMBER_OF_SKYDIPS.GT.1) THEN
                  CALL R8TOR8(MEMORY(IP_DUMUT),MEMORY(IP_SKYUT),
     $            NUMBER_OF_SKYDIPS-1)
                  CALL R4TOR4(MEMORY(IP_DUMTAU),MEMORY(IP_SKYTAU),
     $            NUMBER_OF_SKYDIPS-1)
                  CALL FREE_VM (3*(NUMBER_OF_SKYDIPS-1),WORK1)
               ENDIF
               CALL SAVE_SKYDIP (MEMORY(IP_SKYUT),
     $         MEMORY(IP_SKYTAU),NUMBER_OF_SKYDIPS,UT,TAU)
            ENDIF
97          READ (2,'(a)',ERR=98,END=98) SKYDIP_LINE
         ENDDO
98       CLOSE (UNIT=2)
         CALL SORT_TIME (MEMORY(IP_SKYUT),MEMORY(IP_SKYTAU),
     $   NUMBER_OF_SKYDIPS)
         CALL SIC_DEF_DBLE ('skydip_time',MEMORY(IP_SKYUT),1,
     $   NUMBER_OF_SKYDIPS,.TRUE.,ERROR)
         CALL SIC_DEF_REAL ('skydip_opacity',MEMORY(IP_SKYTAU),1,
     $   NUMBER_OF_SKYDIPS,.TRUE.,ERROR)
      ENDIF
*
* Check for FIT results
*
      FILENAME = 'NIC.FIT'
      CALL SIC_LOWER (FILENAME)
      OPEN (UNIT=2,FILE=FILENAME,FORM='formatted',STATUS='old',
     $IOSTAT=IER)
      CLOSE (UNIT=2)
      IF (IER.EQ.0) WRITE (6,'(a)') 'Retrieving FITs ...'
      IF (FOUND7.AND.INDEX(BOLO_STR,'BOLO_DATA:').EQ.0) THEN
         WRITE (6,'(/a)') 'Logical BOLO_DATA: multiple definition ...'
         WRITE (6,'(a/)')
     $   'Please verify files "~/.gag.dico" and "~/init.nic"'
      ENDIF
*
* Start the real work
*
      IF (N.NE.0) THEN
         CALL PLAY_NIC(COMMAND(1:N))
      ELSE
         CALL ENTER_NIC
      ENDIF
*
* Clean up
*
***      if (x_islo.ne.0) call gdf_fris (x_islo,error)
***      call flush_psc(error)
      CALL EXIT_CLEAR
*
*
      CALL MESSAGE_COMPRESS (MESFILE,5)
*
      IF (DATA_SHMID.NE.0)
     $CALL REMOVE_MEMORY(DATA_SHMID,IADDRRECORD)
      END
*
      SUBROUTINE SAVE_SKYDIP (UT_BUFFER,TAU_BUFFER,N,UT_NEW,TAU_NEW)
      INTEGER N
      REAL*4 TAU_NEW, TAU_BUFFER(1)
      REAL*8 UT_NEW, UT_BUFFER(1)
*
      UT_BUFFER(N) = UT_NEW
      TAU_BUFFER(N) = TAU_NEW
      RETURN
      END
*
      FUNCTION CHECK_OLD_UT (UT_BUFFER,N,UT_NEW)
      INTEGER N, I
      LOGICAL CHECK_OLD_UT
      REAL*8 UT_NEW, UT_BUFFER(1)
*
      CHECK_OLD_UT = .FALSE.
      DO I=1,N
         IF (UT_BUFFER(I).EQ.UT_NEW) CHECK_OLD_UT = .TRUE.
      ENDDO
      RETURN
      END
*
*------------------------------------------------------------------------
*
* SORT_TIME
*
*------------------------------------------------------------------------
      SUBROUTINE SORT_TIME (RA,DA,N)
      INTEGER N, I, J, L, IR
      REAL*4 DA(N), DDA
      REAL*8 RA(N), RRA
*
      IF (N.EQ.1) RETURN
      L = N/2+1
      IR = N
      DO WHILE (N.NE.(N+1))
         IF (L.GT.1) THEN
            L = L-1
            RRA = RA(L)
            DDA = DA(L)
         ELSE
            RRA = RA(IR)
            DDA = DA(IR)
            RA(IR) = RA(1)
            DA(IR) = DA(1)
            IR = IR-1
            IF (IR.EQ.1) THEN
               RA(1) = RRA
               DA(1) = DDA
               RETURN
            ENDIF
         ENDIF
         I = L
         J = L+L
         DO WHILE (J.LE.IR)
            IF (J.LT.IR) THEN
               IF (RA(J).LT.RA(J+1)) J=J+1
            ENDIF
            IF (RRA.LT.RA(J)) THEN
               RA(I) = RA(J)
               DA(I) = DA(J)
               I = J
               J = J+J
            ELSE
               J = IR+1
            ENDIF
         ENDDO
         RA(I) = RRA
         DA(I) = DDA
      ENDDO
      END
