C @(#)copier.for	17.1.1.2 (ESO-DMD) 02/25/02 17:44:52
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
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 ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
      PROGRAM COPIER
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  program COPIER 
C  K. Banse 			ESO - Garching
C
C.KEYWORDS
C  copy, descriptors, keys
C
C.PURPOSE
C  copy objects from one MIDAS structure to another one
C  possible structures are: keyword, descriptor, image
C
C.ALGORITHM
C  use MIDAS interfaces to do the job
C
C.INPUT/OUTPUT
C  the following keywords are used:
C
C  ACTION/C/1/2		qualifier indicating the copy direction
C                    	= XY, for X -> Y copy
C                  	where X,Y any of K,D,I for key,descr,image
C
C  Pi/C/1/30		input/output object as object/type/1.elem./novals
C			or object only
C  i depends on type of copy, since descriptors need 2 tokens to be specified...
C
C.VERSIONS
C  
C  020215		last modif
C
C--------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      BYTELA,BYTELB,CUNLEN
      INTEGER      FIRSTA,FIRSTB,IAV,ITYPE,KNEXT
      INTEGER      N,NN,NAXISA,NOVALA,NOVALB
      INTEGER*8    PNTRA,PNTRB
      INTEGER      PRGLVL,SIZE,STAT
      INTEGER      NPIXA(6),HNC
      INTEGER      IMNOA,IMNOB,FILESW
      INTEGER      UNIT(1),NULLO,MADRID(1)
C
      INTEGER      IBUF(8192)                          !data buffers
      REAL         RBUF(8192)
      CHARACTER    CBUF*32764
      DOUBLE PRECISION  DBUF(4096)
C
      CHARACTER    STRING*80,FRAMEA*80,FRAMEB*80
      CHARACTER    KEYA*15,KEYB*15,DSCRA*80,DSCRB*80
      CHARACTER    TYPEA*12,TYPEB*12,TYPEX*12
      CHARACTER    CUNITA*112,IDENTA*72
      CHARACTER    ACTION*4,PNEXT(3)*4,HTEXT*72
      CHARACTER    ERROR1*30,ERROR2*30
      CHARACTER    RECORD*100,ASCFIL*80,PP1*80,PP2*80
      CHARACTER    OBJA*80, OBJB*80
C
      DOUBLE PRECISION  STARTA(6),STEPA(6)
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C
      COMMON  /VMR/ MADRID
C
      DATA  PNEXT   /'P2  ','P3  ','P4  '/
      DATA  ERROR1  /'descriptor does not exist... '/
      DATA  ERROR2  /'key does not exist... '/
      DATA  NAXISA  /1/,   NPIXA  /6*1/
      DATA  STARTA  /6*0.D0/, STEPA /6*1.D0/
      DATA  IDENTA  /' '/,  CUNITA  /' '/
      DATA  OBJA    /' '/,  OBJB  /' '/
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
C  get into MIDAS
      CALL STSPRO('COPIER')
      CALL STKRDI('MID$MODE',7,1,IAV,PRGLVL,UNIT,NULLO,STAT)   !save proc. level
      CALL STKRDI('PCOUNT',1,1,IAV,N,UNIT,NULLO,STAT)      !get parameter count
      FILESW = 0
      HNC = 0
C
C  get action
      KNEXT = 1
      CALL STKRDC('ACTION',1,1,4,IAV,ACTION,UNIT,NULLO,STAT)
      CALL UPCAS(ACTION,ACTION)
C 
C  check for list option - COPY/LSDD, /LSKD or /LSDK
      IF (ACTION(1:2).EQ. 'LS') THEN
         ACTION(1:2) = ACTION(3:4)             !shift copy_action
         CALL STKRDC('P1',1,1,80,IAV,ASCFIL,UNIT,NULLO,STAT)
         CALL STKRDC('P2',1,1,80,IAV,FRAMEA,UNIT,NULLO,STAT)
         IF (ACTION(1:2).EQ.'DD') THEN
            CALL STKRDC('P3',1,1,80,IAV,FRAMEB,UNIT,NULLO,STAT)
         ELSE
            FRAMEB(1:) = FRAMEA(1:)
         ENDIF
         CALL GENLGN(ASCFIL,CUNITA,110)             !handle LOGICAL:filename
         CUNITA(111:111) = ' '
         N = INDEX(CUNITA,' ') - 1
         OPEN(UNIT=33,FILE=CUNITA(1:N),STATUS='OLD',ERR=99000)
         FILESW = 1                       !indicate, that we have file input
      ELSE
         GOTO 180
      ENDIF
C 
C  reading loop for file input
100   RECORD(1:) = ' '
      READ(33,10000,END=95000) RECORD
      N = 1
      PP1(1:) = ' '                           !PP1, PP2 hold key/descriptor
      CALL EXTRSS(RECORD,' ',N,PP1,IAV)
      IF (IAV.LE.0) GOTO 100                  !skip empty records
      PP2(1:) = ' '
      CALL EXTRSS(RECORD,' ',N,PP2,IAV)
      IF (IAV.LE.0) PP2(1:) = PP1(1:)         !use same descriptor
C 
C                                                            !handle input
180   IF (ACTION(1:1).EQ.'D') THEN
         GOTO 1000
      ELSE IF (ACTION(1:1).EQ.'K') THEN
         GOTO 2000
      ELSE IF (ACTION(1:1).EQ.'I') THEN
         GOTO 5000
      ELSE IF (ACTION(1:1).EQ.'A') THEN
         GOTO 6000
      ELSE
         GOTO 90000
      ENDIF
C                                                            !handle output
200   IF (ACTION(2:2).EQ.'D') THEN
         GOTO 3000
      ELSE IF (ACTION(2:2).EQ.'K') THEN
         GOTO 4000
      ELSE IF (ACTION(2:2).EQ.'I') THEN
         GOTO 5500
      ELSE IF (ACTION(2:2).EQ.'A') THEN
         GOTO 7000
      ELSE
         GOTO 90000
      ENDIF
C ---
C
C  descriptor input...
C
C ---
1000  KNEXT = 2                              !descriptor input needs 2 params...
      IF (FILESW.NE.1) 
     +   CALL STKRDC('P1',1,1,80,IAV,FRAMEA,UNIT,NULLO,STAT)
      CALL CLNFRA(FRAMEA,FRAMEA,0)
      CALL STFOPN(FRAMEA,D_OLD_FORMAT,0,F_OLD_TYPE,IMNOA,STAT)
      IF (FILESW.EQ.1) THEN
         STRING(1:) = PP1(1:)
      ELSE
         CALL STKRDC('P2',1,1,80,IAV,STRING,UNIT,NULLO,STAT)
         N = INDEX(STRING,',')               !check for list of descr.
         IF (N.GT.1) THEN                    !remove first descr + write back
            FILESW = 2
            DSCRA(1:) = STRING(N+1:)//' '
            CALL STKWRC('P2',1,DSCRA,1,80,UNIT,STAT)
            STRING(N:) = ' '
         ELSE
            FILESW = 0
         ENDIF
      ENDIF
      CALL EXTRA(1,STRING,DSCRA,TYPEA,FIRSTA,NOVALA,BYTELA)
      OBJA(1:) = DSCRA(1:)
C
C  check, if defaults are used...
      IF (TYPEA(1:1).NE.' ') THEN
         CALL STDFND(IMNOA,DSCRA,TYPEX,N,NN,STAT)
         CALL FULTYP(TYPEX,NN)
         IF (TYPEA.EQ.TYPEX) GOTO 1500              !same type, so that's o.k.
      ELSE
         CALL STDFND(IMNOA,DSCRA,TYPEA,NOVALA,BYTELA,STAT)
         IF (TYPEA(1:1).NE.' ') THEN
            CALL FULTYP(TYPEA,BYTELA)
            GOTO 1500
         ENDIF
      ENDIF
C 
C  Trouble ... descriptor not found or type mismatch
      N = INDEX(DSCRA,' ') - 1
      IF (N.LT.1) N = LEN(DSCRA)
      STRING(1:) = DSCRA(1:N)//': '//ERROR1
      CALL STTPUT(STRING,STAT)
      GOTO 90000
C
C  check types + lengths
1500  CALL LIMTST(TYPEA,NOVALA,BYTELA,ITYPE)
      GOTO (1600,1633,1666,1699,1622),ITYPE
      GOTO 89000                              !wrong type
C
C  read integer descr
1600  CALL STDRDI(IMNOA,DSCRA,FIRSTA,NOVALA,IAV,IBUF,UNIT,
     +            NULLO,STAT)
      GOTO 1700
C
C  read logical descr                        !use integer buffer
1622  CALL STDRDL(IMNOA,DSCRA,FIRSTA,NOVALA,IAV,IBUF,UNIT,
     +            NULLO,STAT)
      GOTO 1700
C
C  real descriptor
1633  CALL STDRDR(IMNOA,DSCRA,FIRSTA,NOVALA,IAV,RBUF,UNIT,
     +            NULLO,STAT)
      GOTO 1700
C
C  character descriptor
1666  CALL STDRDC(IMNOA,DSCRA,BYTELA,FIRSTA,NOVALA,IAV,CBUF,UNIT,
     +            NULLO,STAT)
      GOTO 1700
C
C  double precision descriptor
1699  CALL STDRDD(IMNOA,DSCRA,FIRSTA,NOVALA,IAV,DBUF,UNIT,
     +            NULLO,STAT)
C
1700  NOVALA = MIN(NOVALA,IAV)
      FIRSTA = 1                        !now input is stored from the beginning
      IF (ACTION(2:2).EQ.'I') THEN                    !define frame stuff,
         IDENTA(1:) = ' '                             !if we copy to image
         IDENTA(1:) = 'copy of descriptor '//DSCRA//
     +                'of frame '//FRAMEA
         NAXISA = 1
         NPIXA(1) = NOVALA
         CUNLEN = 32                              !for 1-dim frame
         STARTA(1) = 0.D0
         STEPA(1) = 1.D0
      ENDIF
C 
      CALL STDRDH(IMNOA,DSCRA,1,72,IAV,HTEXT,HNC,STAT)
      GOTO 200                              !go + work on output now
C ---
C
C  keyword input
C
C ---
2000  IF (FILESW.EQ.1) THEN
         STRING(1:) = PP1(1:)
      ELSE
         CALL STKRDC('P1',1,1,80,IAV,STRING,UNIT,NULLO,STAT)
         N = INDEX(STRING,',')               !check for list of keywords
         IF (N.GT.1) THEN                    !remove first descr + write back
            FILESW = 2
            DSCRA(1:) = STRING(N+1:)//' '
            CALL STKWRC('P1',1,DSCRA,1,80,UNIT,STAT)
            STRING(N:) = ' '
         ELSE
            FILESW = 0
         ENDIF
      ENDIF
      CALL EXTRA(1,STRING,KEYA,TYPEA,FIRSTA,NOVALA,BYTELA)
      N = PRGLVL - 1
      CALL STKWRI('MID$MODE',N,7,1,UNIT,STAT)       !necessary for local keys...
      OBJA(1:) = KEYA(1:)
C
C  check, if defaults are used...
      IF (TYPEA(1:1).NE.' ') THEN
         CALL STKFND(KEYA,TYPEX,N,NN,STAT)
         CALL FULTYP(TYPEX,NN)
         IF (TYPEA.EQ.TYPEX) GOTO 2500              !same type, so that's o.k.
      ELSE
         CALL STKFND(KEYA,TYPEA,NOVALA,BYTELA,STAT)
         IF (TYPEA(1:1).NE.' ') THEN
            CALL FULTYP(TYPEA,BYTELA)
            GOTO 2500
         ENDIF
      ENDIF
C 
C  key not found or type mismatch
      N = INDEX(KEYA,' ') - 1
      IF (N.LT.1) N = LEN(KEYA)
      STRING(1:) = KEYA(1:N)//': '//ERROR2
      CALL STTPUT(STRING,STAT)
      GOTO 90000
C
2500  CALL LIMTST(TYPEA,NOVALA,BYTELA,ITYPE)
      GOTO (2600,2633,2666,2699),ITYPE
      GOTO 89000                              !wrong type
C
C  read integer key
2600  CALL STKRDI(KEYA,FIRSTA,NOVALA,IAV,IBUF,UNIT,NULLO,STAT)
      GOTO 2700
C  real key
2633  CALL STKRDR(KEYA,FIRSTA,NOVALA,IAV,RBUF,UNIT,NULLO,STAT)
      GOTO 2700
C  character key
2666  CALL STKRDC(KEYA,BYTELA,FIRSTA,NOVALA,IAV,CBUF,UNIT,NULLO,STAT)
      GOTO 2700
C  double precision key
2699  CALL STKRDD(KEYA,FIRSTA,NOVALA,IAV,DBUF,UNIT,NULLO,STAT)
C
2700  NOVALA = MIN(IAV,NOVALA)
      FIRSTA = 1
      IF (ACTION(2:2).EQ.'I') THEN                !define frame stuff,
         IDENTA = 'copy of key '//KEYA//' '       !if we copy to image or mask...
         NPIXA(1) = NOVALA
         NAXISA = 1
         CUNLEN = 32                              !for 1-dim frame
         STARTA(1) = 0.D0
         STEPA(1) = 1.D0
      ENDIF
      CALL STKWRI('MID$MODE',PRGLVL,7,1,UNIT,STAT)    !reset procedure level
      GOTO 200                              !go + work on output now...
C ---
C
C  descriptor output...
C
C ---
3000  IF (FILESW.NE.1)
     +   CALL STKRDC(PNEXT(KNEXT),1,1,60,IAV,FRAMEB,UNIT,NULLO,STAT)
      CALL CLNFRA(FRAMEB,FRAMEB,0)
      CALL STFOPN(FRAMEB,D_OLD_FORMAT,0,F_OLD_TYPE,IMNOB,STAT)
      IF (FILESW.EQ.1) THEN
         STRING(1:) = PP2(1:)
      ELSE
         CALL STKRDC(PNEXT(KNEXT+1),1,1,80,IAV,STRING,UNIT,NULLO,STAT)
         N = INDEX(STRING,',')               !check for list of descr.
         IF (N.GT.1) THEN                    !remove first descr + write back
            FILESW = 2
            DSCRB(1:) = STRING(N+1:)//' '
            CALL STKWRC(PNEXT(KNEXT+1),1,DSCRB,1,80,UNIT,STAT)
            STRING(N:) = ' '
         ELSE
            FILESW = 0
         ENDIF
      ENDIF
      CALL EXTRA(1,STRING,DSCRB,TYPEB,FIRSTB,NOVALB,BYTELB)
      OBJB(1:) = DSCRB(1:)
C
C  check types
      IF (TYPEB(1:1).EQ.' ') THEN            !see, if descriptor exists already
         CALL STDFND(IMNOB,DSCRB,TYPEB,NOVALB,BYTELB,STAT)
         IF (TYPEB(1:1).EQ.' ') THEN
            TYPEB = TYPEA
            NOVALB = NOVALA
            BYTELB = BYTELA
         ELSE
            CALL FULTYP(TYPEB,BYTELB)
         ENDIF
      ENDIF
C
C  handle the different type combinations
      IF ( (TYPEA(1:1).EQ.'C') .OR. (TYPEB(1:1).EQ.'C') ) THEN
         NOVALB = MIN(NOVALB,(NOVALA*BYTELA)/BYTELB)
         GOTO 3700                                 !copy character data...
      ENDIF
C 
      NOVALB = MIN(NOVALB,NOVALA)            !take minimum of both lengths
      IF ((TYPEA(1:1).EQ.'I') .OR. (TYPEA(1:1).EQ.'L')) GOTO 3100
      IF (TYPEA(1:1).EQ.'R') GOTO 3120
      IF (TYPEA(1:1).EQ.'D') GOTO 3130
      GOTO 89000                              !invalid type...
C
3100  IF ((TYPEB(1:1).EQ.'I').OR.(TYPEB(1:1).EQ.'L')) THEN
         GOTO 3400
      ELSE IF (TYPEB(1:1).EQ.'R') THEN
         CALL CC(7,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 3500
      ELSE IF (TYPEB(1:1).EQ.'D') THEN
         CALL CC(6,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 3600
      ELSE
         GOTO 89000                              !invalid type...
      ENDIF
C
3120  IF (TYPEB(1:1).EQ.'R') THEN
         GOTO 3500
      ELSE IF ((TYPEB(1:1).EQ.'I').OR.(TYPEB(1:1).EQ.'L')) THEN
         CALL CC(2,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 3400
      ELSE IF (TYPEB(1:1).EQ.'D') THEN
         CALL CC(4,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 3600
      ELSE
         GOTO 89000                              !invalid type...
      ENDIF
C
3130  IF (TYPEB(1:1).EQ.'D') THEN
         GOTO 3600
      ELSE IF ((TYPEB(1:1).EQ.'I').OR.(TYPEB(1:1).EQ.'L')) THEN
         CALL CC(12,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 3400
      ELSE IF (TYPEB(1:1).EQ.'R') THEN
         CALL CC(13,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 3500
      ELSE
         GOTO 89000                              !invalid type...
      ENDIF
C
C  write integer/logical descr
3400  IF (TYPEB(1:1).EQ.'I') THEN
         CALL STDWRI(IMNOB,DSCRB,IBUF,FIRSTB,NOVALB,UNIT,STAT)
      ELSE
         CALL STDWRL(IMNOB,DSCRB,IBUF,FIRSTB,NOVALB,UNIT,STAT)
      ENDIF
      GOTO 3990
C
C  real descriptor
3500  CALL STDWRR(IMNOB,DSCRB,RBUF,FIRSTB,NOVALB,UNIT,STAT)
      GOTO 3990
C
C  double precision descriptor
3600  CALL STDWRD(IMNOB,DSCRB,DBUF,FIRSTB,NOVALB,UNIT,STAT)
      GOTO 3990
C
C  character descriptor
3700  IF (TYPEA(1:1).NE.TYPEB(1:1)) THEN
         GOTO 89000
      ELSE
         CALL STDWRC(IMNOB,DSCRB,BYTELB,CBUF,FIRSTB,NOVALB,UNIT,STAT)
      ENDIF
3990  IF (HNC.GT.0) THEN
         CALL STDWRH(IMNOB,DSCRB,HTEXT,1,HNC,STAT)
         HNC = 0
      ENDIF
      GOTO 90000
C ---
C
C  keyword output
C
C ---
4000  IF (FILESW.EQ.1) THEN
         STRING(1:) = PP2(1:)
      ELSE
         CALL STKRDC(PNEXT(KNEXT),1,1,80,IAV,STRING,UNIT,NULLO,STAT)
         N = INDEX(STRING,',')               !check for list of descr.
         IF (N.GT.1) THEN                    !remove first descr + write back
            FILESW = 2
            DSCRB(1:) = STRING(N+1:)//' '
            CALL STKWRC(PNEXT(KNEXT),1,DSCRB,1,80,UNIT,STAT)
            STRING(N:) = ' '
         ELSE
            FILESW = 0
         ENDIF
      ENDIF
      CALL EXTRA(1,STRING,KEYB,TYPEB,FIRSTB,NOVALB,BYTELB)
      N = PRGLVL - 1
      CALL STKWRI('MID$MODE',N,7,1,UNIT,STAT)      !necessary for local keys...
      OBJB(1:) = KEYB(1:)
C
C  if only keyname, get related info via STKFND
      IF (TYPEB(1:1).EQ.' ') THEN
         CALL STKFND(KEYB,TYPEB,NOVALB,BYTELB,STAT)
         IF (TYPEB(1:1).EQ.' ') THEN
            N = INDEX(KEYB,' ') - 1
            IF (N.LT.1) N = LEN(KEYB)
            STRING(1:) = KEYB(1:N)//': '//ERROR2
            CALL STTPUT(STRING,STAT)
            GOTO 90000
         ELSE
            CALL FULTYP(TYPEB,BYTELB)
         ENDIF
      ENDIF
C
C  handle the different type combinations
      IF ( (TYPEA(1:1).EQ.'C') .OR. (TYPEB(1:1).EQ.'C') ) THEN
         NOVALB = MIN(NOVALB,(NOVALA*BYTELA)/BYTELB)
         GOTO 4700
      ENDIF
C
      NOVALB = MIN(NOVALB,NOVALA)
      IF ((TYPEA(1:1).EQ.'I').OR.(TYPEA(1:1).EQ.'L')) GOTO 4100
      IF (TYPEA(1:1).EQ.'R') GOTO 4120
      IF (TYPEA(1:1).EQ.'D') GOTO 4150
      GOTO 89000                              !invalid type...
C
4100  IF (TYPEB(1:1).EQ.'I') THEN
         GOTO 4400
      ELSE IF (TYPEB(1:1).EQ.'R') THEN
         CALL CC(7,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 4500
      ELSE IF (TYPEB(1:1).EQ.'D') THEN
         CALL CC(6,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 4600
      ELSE
         GOTO 89000                              !invalid type...
      ENDIF
C
4120  IF (TYPEB(1:1).EQ.'R') THEN
         GOTO 4500
      ELSE IF (TYPEB(1:1).EQ.'I') THEN
         CALL CC(2,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 4400
      ELSE IF (TYPEB(1:1).EQ.'D') THEN
         CALL CC(4,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 4600
      ELSE
         GOTO 89000                              !invalid type...
      ENDIF
C
4150  IF (TYPEB(1:1).EQ.'D') THEN
         GOTO 4600
      ELSE IF (TYPEB(1:1).EQ.'I') THEN
         CALL CC(12,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 4400
      ELSE IF (TYPEB(1:1).EQ.'R') THEN
         CALL CC(13,DBUF,RBUF,IBUF,DBUF,RBUF,IBUF,FIRSTA,1,NOVALB)
         GOTO 4500
      ELSE
         GOTO 89000                              !invalid type...
      ENDIF
C
C  write integer key
4400  CALL STKWRI(KEYB,IBUF,FIRSTB,NOVALB,UNIT,STAT)
      GOTO 90000
C
C  real key
4500  CALL STKWRR(KEYB,RBUF,FIRSTB,NOVALB,UNIT,STAT)
      GOTO 90000
C
C  double precision key
4600  CALL STKWRD(KEYB,DBUF,FIRSTB,NOVALB,UNIT,STAT)
      GOTO 90000
C
C  character key
4700  IF (TYPEA(1:1).NE.TYPEB(1:1)) THEN
         GOTO 89000
      ELSE
         CALL STKWRC(KEYB,BYTELB,CBUF,FIRSTB,NOVALB,UNIT,STAT)
         GOTO 90000
      ENDIF
C ---
C
C  image frame input
C
C ---
5000  CALL STKRDC('P1',1,1,80,IAV,STRING,UNIT,NULLO,STAT)
      CALL EXTRA(2,STRING,FRAMEA,TYPEA,FIRSTA,NOVALA,BYTELA)
      CALL CLNFRA(FRAMEA,FRAMEA,0)
      CALL STIGET(FRAMEA,D_R4_FORMAT,F_I_MODE,1,6,NAXISA,NPIXA,
     +            STARTA,STEPA,IDENTA,CUNITA,PNTRA,IMNOA,STAT)
      IF (TYPEA(1:1).EQ.' ') THEN                        !handle default
         NOVALA = 1
         DO 5050, N=1,NAXISA
            NOVALA = NOVALA * NPIXA(N)
5050     CONTINUE
      ENDIF
      CUNLEN = (NAXISA+1) * 16                  !compute length of CUNIT
C
C  check limits 
      CALL LIMTST('R',NOVALA,1,N)            !truncate, if necessary
      CALL CC(1,DBUF,MADRID(PNTRA),IBUF,DBUF,RBUF,IBUF,
     +        FIRSTA,1,NOVALA)
      TYPEA(1:) = 'R '
      GOTO 200                              !go + get destination object
C ---
C
C  image frame output
C
C ---
5500  CALL STKRDC(PNEXT(KNEXT),1,1,80,IAV,STRING,UNIT,NULLO,STAT)
      CALL EXTRA(2,STRING,FRAMEB,TYPEB,FIRSTB,NOVALB,BYTELB)
      CALL CLNFRA(FRAMEB,FRAMEB,0)
      IF (TYPEB(1:1).EQ.' ') THEN
         NOVALB = NOVALA
      ELSE
         NOVALB = MIN(NOVALA,NOVALB)
      ENDIF
C
C  create new image frame...
      IF (CUNLEN.LT.112) CUNITA(CUNLEN+1:) = ' '
      CALL STIPUT(FRAMEB,D_R4_FORMAT,F_O_MODE,1,NAXISA,NPIXA,STARTA,
     +            STEPA,IDENTA,CUNITA,PNTRB,IMNOB,STAT)
      SIZE = 1
      DO 5550, N=1,NAXISA
         SIZE = SIZE*NPIXA(N)
5550  CONTINUE
      IF (SIZE.GT.NOVALB) CALL ICLEAR(MADRID(PNTRB),SIZE)      !clear frame...
C
C  now proceed according to source input
      IF ((TYPEA(1:1).EQ.'I').OR.(TYPEA(1:1).EQ.'L')) THEN
         CALL CC(7,DBUF,RBUF,IBUF,DBUF,MADRID(PNTRB),IBUF,
     +           1,FIRSTB,NOVALB)
      ELSE IF (TYPEA(1:1).EQ.'R') THEN            !R -> R
         CALL CC(1,DBUF,RBUF,IBUF,DBUF,MADRID(PNTRB),IBUF,
     +           1,FIRSTB,NOVALB)
      ELSE IF (TYPEA(1:1).EQ.'D') THEN            !D -> R
         CALL CC(13,DBUF,RBUF,IBUF,DBUF,MADRID(PNTRB),IBUF,
     +           1,FIRSTB,NOVALB)
      ELSE
         GOTO 89000
      ENDIF
      GOTO 90000                        !goto common endpoint...
C ---
C
C  ASCII file input - only output to descr is supported
C
C ---
C 
6000  CALL STKRDC('P1',1,1,80,IAV,STRING,UNIT,NULLO,STAT)
      N = INDEX(STRING,' ') - 1
      IF (N.LE.0) N = LEN(STRING)
      CALL STKRDI('INPUTI',1,1,IAV,SIZE,UNIT,NULLO,STAT)   !get max length
      IF ((SIZE.LT.1) .OR. (SIZE.GT.100)) SIZE = 100
C 
C  first loop to get max. record size
      OPEN(UNIT=34,FILE=STRING(1:N),STATUS='OLD',ERR=98000)
      BYTELA = 1
      NOVALA = 0
6060  RECORD(1:) = ' '
      READ(34,10000,END=6300) RECORD(1:100)
      DO 6260, N=100,1,-1
         IF (RECORD(N:N).NE.' ') THEN
            IF (N.GT.BYTELA) BYTELA = N           !no. of bytes per element
            GOTO 6060
         ENDIF
6260  CONTINUE
      GOTO 6060
C 
6300  REWIND(UNIT=34)                            !2nd loop - we really read
      IF (SIZE.GT.BYTELA) SIZE = BYTELA          !minimize byte count 
      IAV = SIZE - 1
      NN = 1
C 
6360  RECORD(1:) = ' '
      READ(34,10000,END=6600) RECORD(1:BYTELA)
      DO 6460, N=BYTELA,1,-1
         IF (RECORD(N:N).NE.' ') THEN
            NOVALB = N
            GOTO 6480
         ENDIF
6460  CONTINUE
      GOTO 6360
C 
6480  IF (NN.GT.32664) THEN
         CLOSE(UNIT=34)
         CALL STETER(3,'ASCII file too big ( > 32664 chars.) ...')
      ENDIF
C 
      IF (NOVALB.LE.SIZE) THEN
         CBUF(NN:NN+IAV) = RECORD(1:SIZE)
         NN = NN + SIZE
         NOVALA = NOVALA + 1
      ELSE
6490     CBUF(NN:NN+IAV) = RECORD(1:SIZE)
         NOVALA = NOVALA + 1
         NN = NN + SIZE
         NOVALB = NOVALB - SIZE
         IF (NOVALB.GT.0) THEN
            RECORD(1:) = RECORD(SIZE+1:)//' '        !fill with blanks
            GOTO 6490
         ENDIF
      ENDIF
      GOTO 6360
C
C  end-of-file reached
6600  BYTELA = SIZE
      CLOSE(UNIT=34)
C 
      TYPEA = 'C'
      GOTO 200
C ---
C
C  ASCII file output 
C
C ---
C
7000  IF (TYPEA(1:1).NE.'C') THEN
         NN = 1
         IF ((TYPEA(1:1).EQ.'I').OR.(TYPEA(1:1).EQ.'L')) THEN
            BYTELA = 10
            IAV = BYTELA - 1
            DO 7100, N=1,NOVALA
               WRITE(CBUF(NN:NN+IAV),20000) IBUF(N)
               NN = NN + BYTELA
7100        CONTINUE
         ELSEIF (TYPEA(1:1).EQ.'R') THEN
            BYTELA = 15
            IAV = BYTELA - 1
            DO 7200, N=1,NOVALA
               WRITE(CBUF(NN:NN+IAV),20001) RBUF(N)
               NN = NN + BYTELA
7200        CONTINUE
         ELSE
            BYTELA = 25
            IAV = BYTELA - 1
            DO 7300, N=1,NOVALA
               WRITE(CBUF(NN:NN+IAV),20002) DBUF(N)
               NN = NN + BYTELA
7300        CONTINUE
         ENDIF
      ENDIF
      CALL STKRDC('P3',1,1,80,IAV,STRING,UNIT,NULLO,STAT)
      N = INDEX(STRING,' ') - 1
      IF (N.LE.0) N = LEN(STRING)
      NN = 1
      OPEN(UNIT=34,FILE=STRING(1:N),STATUS='NEW',ERR=98000)
      IAV = BYTELA - 1
      NN = 1
      DO 7700, N=1,NOVALA
         WRITE(34,10000) CBUF(NN:NN+IAV)
         NN = NN + BYTELA
7700  CONTINUE
      CLOSE(UNIT=34)
C
      GOTO 90000                        !goto common endpoint...
C 
C  --------------------------------------------
C
C  types of input + output object don't match
C 
89000 N = INDEX(OBJA,' ') - 1
      IF (N.LT.1) N = LEN(OBJA)
      NN = INDEX(OBJB,' ') - 1
      IF (NN.LT.1) NN = LEN(OBJB)
      WRITE(STRING,10001) OBJA(1:N),OBJB(1:NN)
      CALL STTPUT(STRING,STAT)
C
C  we're done - unless we use the `list' option
C
90000 IF (FILESW.EQ.1) THEN
         GOTO 100
      ELSEIF (FILESW.EQ.2) THEN
         GOTO 180
      ENDIF
C 
      CALL STKWRI('MID$MODE',PRGLVL,7,1,UNIT,STAT)      !reset procedure level
      CALL STSEPI
C
C  file loop terminated
95000 CLOSE(UNIT=33)
      FILESW = 0
      GOTO 90000                        !terminate normally
C
C  file open error
98000 IF (NN.EQ.0) THEN
         RECORD(1:) = 'Problems opening ASCII file: '//STRING(1:N)
      ELSE
         RECORD(1:) = 'Problems creating ASCII file: '//STRING(1:N)
      ENDIF
      CALL STETER(1,RECORD)
C 
99000 RECORD(1:) = 'Problems with ASCII list: '//ASCFIL(1:)
      CALL STETER(1,RECORD)
C 
10000 FORMAT(A)
10001 FORMAT
     +('types of "',A,'" (input) + "',A,'" (output) do not match...')
20000 FORMAT(I10)
20001 FORMAT(E15.8)
20002 FORMAT(E25.12)
C 
      END

      SUBROUTINE FULTYP(TYPE,BYTVAL)
C
      IMPLICIT NONE
C
      INTEGER    BYTVAL
C
      CHARACTER*(*)  TYPE
C
      IF (TYPE(1:1).EQ.'C') THEN
         IF (BYTVAL.GT.1) THEN
            WRITE(TYPE,10100) BYTVAL                !build CHAR*00005
         ELSE
            TYPE(2:) = ' '
         ENDIF
      ELSE
         TYPE(2:) = ' '
      ENDIF
      RETURN
C 
10100 FORMAT('CHAR*',I5.5)
      END

      SUBROUTINE EXTRA(FLAG,STRING,NAME,TYPE,FIRST,NOVAL,BYTVAL)
C
      IMPLICIT NONE
C
      INTEGER    FLAG,FIRST,NOVAL,BYTVAL
      INTEGER    START,M,LL,SLEN
C 
C  TYPE is returned as 'I', 'R', 'D', 'C' or 'CHAR*nnnnn'
C
      CHARACTER*(*)  STRING,NAME,TYPE
      CHARACTER      CC*10
C
C  test, if default is used
      TYPE(1:) = ' '
      NAME(1:) = ' '                              !clear output name first
      LL = INDEX(STRING,'/')
      IF (LL.LE.0) THEN
         NAME(1:) = STRING(1:)
         FIRST = 1
         RETURN
      ENDIF
C
C  extract info
      START = 1
      CALL EXTRSS(STRING,'/',START,NAME,SLEN)
C 
      IF (FLAG.EQ.1) THEN                         !descr + key have type 
         CALL EXTRSS(STRING,'/',START,TYPE,SLEN)
         CALL UPCAS(TYPE,TYPE)
         IF (TYPE(1:1).EQ.'I') THEN
            BYTVAL = 4
            TYPE(2:) = ' '
         ELSE IF (TYPE(1:1).EQ.'R') THEN
            BYTVAL = 4
            M = INDEX(TYPE,'*')                   !look for R*8
            IF (M.GT.1) THEN
               M = M + 1
               CALL GENCNV(TYPE(M:),1,1,FIRST,FIRST,FIRST,SLEN)
               IF ((SLEN.EQ.1) .AND. (FIRST.EQ.8)) THEN
                  BYTVAL = 8
                  TYPE(1:1) = 'D'
               ENDIF
            ENDIF
            TYPE(2:) = ' '
         ELSE IF (TYPE(1:1).EQ.'D') THEN
            BYTVAL = 8
            TYPE(2:) = ' '
         ELSE IF (TYPE(1:1).EQ.'C') THEN
            M = INDEX(TYPE,'*')
            IF (M.GT.1) THEN
               M = M + 1
               CALL GENCNV(TYPE(M:),1,1,BYTVAL,BYTVAL,BYTVAL,SLEN)
               IF (SLEN.EQ.1) THEN
                  WRITE(TYPE,11000) BYTVAL
               ELSE
                  TYPE(1:1) = ' '
                  RETURN
               ENDIF
            ELSE
               BYTVAL = 1
               TYPE(2:) = ' '
            ENDIF
         ELSE
            TYPE(1:1) = ' '
            RETURN                                !no type there ...
         ENDIF
      ELSE
         TYPE(1:) = 'X '
      ENDIF
C 
      CALL EXTRSS(STRING,'/',START,CC,SLEN)
      IF (SLEN.GT.0)
     +   CALL GENCNV(CC,1,1,FIRST,FIRST,FIRST,SLEN)
      IF (SLEN.LE.0) GOTO 9000
      IF (FIRST.LE.0) FIRST = 1
C
      CALL EXTRSS(STRING,'/',START,CC,SLEN)
      IF (SLEN.GT.0)
     +   CALL GENCNV(CC,1,1,NOVAL,NOVAL,NOVAL,SLEN)
      IF ((SLEN.LE.0) .OR. (NOVAL.LE.0)) GOTO 9000
C
      RETURN
C
C  format errors
9000  CALL STETER(7,'wrong syntax... ')
      RETURN
C 
11000 FORMAT('CHAR*',I5.5)
      END

      SUBROUTINE LIMTST(TYPE,IVAL,BYTVAL,ITYPE)
C
      IMPLICIT NONE
C
      INTEGER     IVAL,BYTVAL,ITYPE,N,STAT
      INTEGER     LIMITS(5)
C
      CHARACTER*(*)   TYPE
      CHARACTER     MESSA*60,TT(5)*1
C
      DATA  LIMITS  /8192,8192,32764,4096,8192/
      DATA  TT      /'I','R','C','D','L'/
C
      IF (IVAL.LE.0)
     +   CALL STETER(2,'no. of elements < 1 ...')
C 
      DO 1520, N=1,5
         IF (TYPE(1:1).EQ.TT(N)) THEN
            ITYPE = N
            GOTO 1600
         ENDIF
1520  CONTINUE
      ITYPE = -1
      RETURN
C 
1600  IF (TYPE(1:1).EQ.'C') THEN
         N = IVAL * BYTVAL
         IF (LIMITS(ITYPE).LT.N) THEN
            IVAL = (LIMITS(ITYPE)/BYTVAL) * BYTVAL
            IF (IVAL.LE.0)
     +         CALL STETER(3,'nobytes per element too large ...')
            WRITE(MESSA,10010) IVAL,BYTVAL
            CALL STTPUT(MESSA,STAT)
         ENDIF
      ELSE
         IF (LIMITS(ITYPE).LT.IVAL) THEN
            IVAL = LIMITS(ITYPE)
            WRITE(MESSA,10000) IVAL
            CALL STTPUT(MESSA,STAT)
         ENDIF
      ENDIF
C
      RETURN
C
10000 FORMAT('no. of values truncated to ',I6)
10010 FORMAT('no. of values truncated to ',I6,' *',I5,' bytes')
      END

      SUBROUTINE CC(FLAG,DA,A,IA,DB,B,IB,FIRSTA,FIRSTB,NDIM)
C
      IMPLICIT NONE
C
      INTEGER      FLAG,FIRSTA,FIRSTB,NDIM
      INTEGER      IA(*),IB(*)
      INTEGER      OFFA,OFFB,I
C
C
      REAL         A(*),B(*)
C
      DOUBLE PRECISION   DA(*),DB(*)
C
C  branch according to FLAG:
C  1 = A -> B                           A: key, descr, image
C  2 = A -> IB                         IA: key, descr, LUT, ITT
C  4 = A -> DB                         DA: key
C                 12 = DA -> IB            - same for B -
C  6 = IA -> DB   13 = DA -> B
C  7 = IA -> B
C
      OFFA = FIRSTA - 1
      OFFB = FIRSTB - 1
      GOTO (100,200,9000,400,9000,600,700,
     +      9000,9000,9000,9000,1200,1300),FLAG
      GOTO 9000                                  !wrong option ...
C
C  copy A to B
100   DO 120, I=1,NDIM
         B(OFFB+I) = A(OFFA+I)
120   CONTINUE
      RETURN
C
C  copy A to IB
200   DO 220, I=1,NDIM
         IB(OFFB+I) = NINT(A(OFFA+I))
220   CONTINUE
      RETURN
C  copy A to DB
C 
400   DO 420, I=1,NDIM
         DB(OFFB+I) = A(OFFA+I)
420   CONTINUE
      RETURN
C
C  copy IA to DB
600   DO 620, I=1,NDIM
         DB(OFFB+I) = IA(OFFA+I)
620   CONTINUE
      RETURN
C
C  copy IA to B
700   DO 720, I=1,NDIM
         B(OFFB+I) = IA(OFFA+I)
720   CONTINUE
      RETURN
C
C  copy DA to IB
1200  DO 1220, I=1,NDIM
         IB(OFFB+I) = NINT(DA(OFFA+I))
1220  CONTINUE
      RETURN
C
C  copy DA to B
1300  DO 1320, I=1,NDIM
         B(OFFB+I) = DA(OFFA+I)
1320  CONTINUE
      RETURN
C
9000  RETURN
      END

      SUBROUTINE ICLEAR(A,NDIM)
C
      IMPLICIT NONE
C
      INTEGER     NDIM
      INTEGER     N
C
      REAL        A(NDIM)
C
      DO 100, N=1,NDIM
         A(N) = 0.
100   CONTINUE
C
      RETURN
      END