/*===========================================================================
  Copyright (C) 1996-2011 European Southern Observatory (ESO)
 
  This program is free software; you can redistribute it and/or 
  modify it under the terms of the GNU General Public License as 
  published by the Free Software Foundation; either version 2 of 
  the License, or (at your option) any later version.
 
  This program is distributed in the 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
  GNU General Public License for more details.
 
  You should have received a copy of the GNU General Public 
  License along with this program; if not, write to the Free 
  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
  MA 02139, USA.
 
  Correspondence concerning ESO-MIDAS should be addressed as follows:
	Internet e-mail: midas@eso.org
	Postal address: European Southern Observatory
			Data Management Division 
			Karl-Schwarzschild-Strasse 2
			D 85748 Garching bei Muenchen 
			GERMANY
===========================================================================*/

/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.IDENT      fitsrhd.c
.LAUGUAGE   C
.AUTHOR     P.Grosbol   ESO/IPG
.KEYWORDS   FITS header, decode, transport format
.COMMENT    Both main and extension headers are decoded.
.VERSION    1.0  1988-Dec-10 : Creation,   PJG 
.VERSION    1.1  1989-Jul-05 : Include more data type in tables, PJG 
.VERSION    1.3  1989-Oct-23 : Create table for RGROUP, PJG 
.VERSION    1.35 1990-Mar-08 : Change CUNIT desc. to C*1, PJG 
.VERSION    1.5  1990-Nov-07 : Add table display format, PJG 
.VERSION    2.20 1991-Sep-23 : Add BINTABLE field types C,M,P, PJG 
.VERSION    2.40 1992-Aug-13 : Include IMAGE extension, PJG 
.VERSION    2.55 1993-Oct-29 : Initiate O_TIME and O_POS, PJG 
.VERSION    2.60 1993-Dec-03 : Correct pointer type in dread call, PJG 
.VERSION    2.70 1994-Sep-29 : Initiate O_TIME also in tables, PJG 
.VERSION    2.75 1995-Jun-07 : use F_TRANS and check TDISP format, PJG 
.VERSION    2.85 1996-Dec-13 : Check format for scaled int-columns, PJG 
.VERSION    2.90 1997-Nov-19 : use SCFCRE with F_H_MODE + SCFMOD to create
			       the Midas images,  KB
.VERSION    2.95 1998-Apr-22 : Change BTABLE 'B' format to I2, PJG 
.VERSION    3.05 1999-Apr-30 : Store IDENT for empty data images, PJG

 110929		last modif 
---------------------------------------------------------------------*/

#include   <fitsfmt.h>               /* general data definitions     */
#include   <fitsdef.h>               /* basic FITS definitions       */
#include   <fitskwt.h>               /* Table Extension definitions  */
#include   <midas_def.h>
#include   <errext.h>
#include   <math.h>

#include   <string.h>
#include   <stdlib.h>
#include   <stdio.h>

 
typedef struct 
   {					/* one FITS header line         */
   char   c[80];
   } LINE;

/*

*/

#ifdef __STDC__
int fitsrhd(int *pmfd, BFDEF *bfdef, int *psize, int *pmfdt, char fmt, 
            char hist, int popt, int Midas_flag)
#else
int fitsrhd(pmfd,bfdef,psize,pmfdt,fmt,hist,popt,Midas_flag)
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE       Decode FITS header
.RETURN        type of FITS header, -1: error
---------------------------------------------------------------------*/
int        *pmfd;            /* OUT:    MIDAS file desc.             */
BFDEF      *bfdef;           /* OUT:    FITS header parm's           */
int        *psize;           /* OUT:    size of data matrix (bytes)  */
int        *pmfdt;           /* IN/OUT: MIDAS file desc. for groups  */
char       fmt;              /* IN:     MIDAS file format No/Orig/Fp */
char       hist;             /* IN:     History flag, No/Yes         */
int        popt;             /* IN:     Print level                  */
int        Midas_flag;       /* IN:     = 0, `usual' mode
					= 1, internal FITS access  
					= -1, only test FITS file type,
					      do not create internal 
					      FITS files	     */
#endif

{
char     *ifn, *tfn, *pc, line[80], outnam[40];
char     helptext[40], ccunit[120];

int      ktype, htype, m, i, n, nl, nx, nz, nrep, nfz, myempty,create_1;
int      ftype, dtype, xtype, na[MXDIM], unit[2], save_name;
int      mfd, mfdt, option, istat, dflag, delt_flag, second_time, uns32;
static int last_htype;
register int nr;

int  fitsXckw(), SCTMES(), get_cdelt();


float    ff[4];

double   fdd[7], fda[7], fdb[7], fdc[7], dx, dy;

LINE     *pl;
KWORD    kw;
TXDEF    *txd;
ADEF     *ad;
PDEF     *pm;
FDEF     *fc;



pl = (LINE *) 0;
txd = (TXDEF *) 0;
htype = NOFITS; ktype = 1; 
nl = dtype = ftype = nfz = unit[0] = 0;
mfd = *pmfd; mfdt = *pmfdt; *psize = 0;
delt_flag = second_time = 0;
save_name = myempty = create_1 = 0;
uns32 = 0;


mdb_init();

/*
printf("Entering fitsrhd: Midas_flag = %d, bfdef->cflag = %d, popt = %d\n",
Midas_flag,bfdef->cflag,popt);
*/


/* interpret the optional mode-offset (100, 200, ...) for Midas_flag 
   which is in interval [-9,9], and remove it afterwards  */

if (Midas_flag > 90)
   {
   myempty = 1;                 /* save also empty primary header */

   if (Midas_flag > 290)
      {                         /* we're really after an extension */
      create_1 = 1;
      Midas_flag -= 300;
      }
   else if (Midas_flag > 190)
      {                         /* we're here from infile.c or indisk.c */
      save_name = 1;
      Midas_flag -= 200;
      }
   else
      Midas_flag -= 100;
   }


if (bfdef->cflag == 1)		/* we didn't create a Midas frame in the */
   {				/* previous run, that means keyword PCOUNT */
   second_time = 1;		/* and/or GCOUNT were missing in the header */
   htype = last_htype;
   (void) SCKRDI("AUX_MODE",18,1,&istat,&n,unit,unit);
   if (n == 0) SCTPUT
      ("keywords PCOUNT and/or GCOUNT are missing - incorrect FITS header ...");
   goto cflag_check;
   }


/* this is the "info" loop */

if (Midas_flag == -2)
   {
   do 						/* main loop: */
      {						/* go through FITS header  */
      if ((n=dread(&pc,FITSLR))!=FITSLR)	/* read all header blocks */
         {
         nl = 0;
         return EOFITS;
         }
      
      bfdef->count ++;
      pl = (LINE *) pc;

      for (n=0; n<36 && ktype; n++, pl++) 	/* decode the 36 lines */
         {					/* of each header block */
         nl++;
         fitsrkw(pl->c,&kw,&m);	/* decode single keyword line */
         if (m != 0) uns32 = m;  	/* catch 32 bit unsigned int */

         if (nl<8)		/* this check only in the beginning */
            {				/* check type of FITS header  */
            if ((htype=fitsthd(nl,&kw)) < FBFITS) return htype;

            /* if we have NAXIS > 0, it's an image + we can leave already */
            if (bfdef->naxis > 0)
               {	
               *psize = 33;		/* indicate artificial size */
               return htype;
               }
	    }

         /* decode KW (only look for some of the mandatory keywords) */

         ktype = fitsXckw(mfd,bfdef,htype,&kw);
         if (ktype < -1) 
            {
            if (ktype == -9)	/* malloc problem in hdr_tbl_M() */
               SCTMES(M_RED_COLOR,"Out of (virtual) memory.");
            return -1;
            }

         }				/* end of for loop */

      } while (ktype);			/* end of main (do) loop */
   }


/* here the "real" loop */

else
   {
   do 						/* main loop: */
      {						/* go through FITS header  */
      if ((n=dread(&pc,FITSLR))!=FITSLR)	/* read all header blocks */
         {
         nl = 0;
         return EOFITS;
         }
      
      bfdef->count ++;
      pl = (LINE *) pc;

      for (n=0; n<36 && ktype; n++, pl++) 	/* decode the 36 lines */
         {					/* of each header block */
         nl++;
         fitsrkw(pl->c,&kw,&m);	/* decode single keyword line */
         if (m != 0) uns32 = m; 	/* catch 32bit unsigned int */

         if (nl<5)
            {				/* check type of FITS header  */
            if ((htype=fitsthd(nl,&kw)) < FBFITS) return htype;
	    }

         if (1<popt) 
            {
            pl->c[79] = '\0';
            SCTPUT(pl->c);
            }
 
         /* decode KW (look for the mandatory keywords, etc.) */

         ktype = fitsckw(mfd,bfdef,htype,&kw,fmt,hist,&dflag,Midas_flag);
         if (ktype < -1) 
            {
            if (ktype == -9)	/* malloc problem in hdr_tbl_M() */
               SCTMES(M_RED_COLOR,"Out of (virtual) memory.");
            return -1;
            }
         if (dflag == 1) delt_flag = 1;

        cflag_check:
         if (0 < bfdef->cflag)		/* if create_flag is set, */
            {				/* create MIDAS frame   */
            switch (htype) 
               {
               case RGROUP :
                if (bfdef->pcount) 
                   {
		   tfn = newfn('T',"");
                   dtype = D_R8_FORMAT; 
		   txd = (TXDEF *) bfdef->extd;
                   nz = 2 * bfdef->pcount;
		   if (Midas_flag == 0)
                      {
                      ftype = F_TBL_TYPE;
                      option = F_O_MODE;
                      }
                   else if (Midas_flag == -1)
		      goto next_step;
                   else
                      {
                      ftype = F_FTBL_TYPE;
                      option = F_FO_MODE;
                      }
		   istat = TCTINI(tfn,0,option,nz,bfdef->gcount,&mfdt);
                   /* 
                   printf("fitsrhd: TCTINI(%s,...), istat = %d\n",tfn,istat);
                   */
                   if (istat != ERR_NORMAL) return (-999);
                   for (nr=0; nr<72; nr++) line[nr] = ' '; line[nr] = '\0';
                   SCDWRC(mfdt,"IDENT",1,line,1,72,unit);
                   }

               case IMAGE  :
               case BFITS  :
                if (fmt=='O')			/* original format */
                   switch (bfdef->bitpix)
                      {
                      case   8 : dtype = D_I1_FORMAT; break;
                      case  16 : dtype = D_I2_FORMAT; break;
                      case  32 : dtype = D_I4_FORMAT; break;
                      case -32 : dtype = D_R4_FORMAT; break;
                      case -64 : dtype = D_R8_FORMAT; break;
                      default  : return htype;
                      }
                else dtype = D_R4_FORMAT;	/* take float format */

                nfz = 1;			/* compute size in bytes */
                nx = (htype==RGROUP) ? bfdef->naxis-1 : bfdef->naxis;
	        if (1<bfdef->gcount) 
                   {				/* add Group Dimension  */
		   if (htype!=RGROUP) bfdef->naxis++;
		   bfdef->data[bfdef->naxis-1].naxis = bfdef->gcount;
		   }

                for (nr=0; nr<nx; nr++) nfz *= bfdef->data[nr].naxis;
                nfz = (bfdef->naxis) ?
	              bfdef->gcount * (nfz + bfdef->pcount) : 0;

                i = (bfdef->bitpix<0) ? -bfdef->bitpix/8 : bfdef->bitpix/8;
                *psize = i * nfz;		/* data size in bytes */
                    
                /* do we just want to know the FITS (extension) type? */

	        if (Midas_flag == -1) goto next_step;


                if ((myempty == 1) && (nfz == 0)) 
                   nfz = 1;			/* so we create an image */
                else
                   myempty = 0;

                if (nfz || hist=='A') 
                   {				/* don't create empty file */
	           ifn = newfn('I',"");
                   if (Midas_flag == 1)
                      {
                      ftype = F_FIMA_TYPE;	/* header -> memory */
                      option = F_O_MODE;	
                      }
                   else
                      {
                      ftype = F_IMA_TYPE;	
                      option = F_H_MODE;	/* only header -> disk */
                      }

		   if (create_1 == 1)		/* we just need the size */
		      nz = 1;		/* don't create the full image */
                   else
		      nz = nfz;
	           istat = SCFCRE(ifn,dtype,option,ftype,nz,&mfd);
                   /* 
                   printf("fitsrhd: SCFCRE(%s,...), istat = %d\n",ifn,istat);
                   */
                   if (istat != ERR_NORMAL) return (-998);
 
                   if (myempty == 1) 
		      {
		      *psize = nfz = 0;		/* reset data size + nfz */
	              }
	           }

	        else if (bfdef->mtype == F_FIT_TYPE) 
                   {
		   ifn = newfn('F',""); 
                   if (Midas_flag == 1)
                      ftype = F_FFIT_TYPE;
                   else
                      ftype = F_FIT_TYPE;

		   istat = SCFCRE(ifn,dtype,F_O_MODE,ftype,1,&mfd);
                   /* 
                   printf("fitsrhd: SCFCRE(%s,...), istat = %d\n",ifn,istat);
                   */
                   if (istat != ERR_NORMAL) return (-998);
 
		   bfdef->naxis = 1;
		   bfdef->data[0].naxis = 1;
		   }

   	        /* we can just add all the descriptors - no check needed */
	        if (0 <= mfd)
                   {
		   for (nr=0; nr<72; nr++) line[nr] = ' '; line[nr] = '\0';
		   xSCDWRI(mfd,"NAXIS",&bfdef->naxis,1,1,unit);
		   if (0<bfdef->naxis)
                      {
		      for (i=0; i<bfdef->naxis; i++)
		         na[i] = bfdef->data[i].naxis;
		      xSCDWRI(mfd,"NPIX",na,1,bfdef->naxis,unit);
		      for (i=0; i<bfdef->naxis; i++) fdd[i] = 1.0;
		      xSCDWRD(mfd,"START",fdd,1,bfdef->naxis,unit);
		      xSCDWRD(mfd,"STEP",fdd,1,bfdef->naxis,unit);
		      xSCDWRC(mfd,"IDENT",1,line,1,72,unit);
		      xSCDWRC(mfd,"CUNIT",1,line,1,16*(bfdef->naxis+1),unit);
		      for (nr=0; nr<4; nr++) ff[nr] = 0.0;
                      xSCDWRR(mfd,"LHCUTS",ff,1,4,unit);
		      }
 		   for (nr=0; nr<7; nr++) fdd[nr] = 0.0;
		   xSCDWRD(mfd,"O_POS",fdd,1,3,unit);
		   xSCDWRD(mfd,"O_TIME",fdd,1,7,unit);
                   }
                break;

               case ATABLE :
               case BTABLE :
                dtype = D_R4_FORMAT; 
	        txd = (TXDEF *) bfdef->extd;
	        nz = 0;
	        for (nr=0; nr<txd->tfields; nr++)
                   {
                   fc = &txd->col[nr];
		   nrep = (0<fc->trepn) ? fc->trepn : 1;
		   nrep *= fc->tncpf;
		   switch (fc->tdfmt) 
                      {
		      case 'A' : nz += (nrep*fc->twdth-1)/4 + 1;
			         break;
		      case 'L' : nz += (nrep-1)/4 + 1;
			         break;
		      case 'X' : nz += (nrep-1)/32 + 1;
			         break;
		      case 'B' : 
		      case 'S' : nz += (nrep-1)/2 + 1;
			         break;
		      case 'I' : 
		      case 'C' : 
		      case 'P' : 
		      case 'E' : nz += nrep * fc->tncpf; 
                                 break;
		      case 'M' : 
		      case 'D' : nz += 2 * nrep * fc->tncpf; 
                                 break;
		      }
                   }
                *psize = bfdef->pcount +
		         (bfdef->data[0].naxis * bfdef->data[1].naxis);

	        if (Midas_flag == 0)
                   {
                   ftype = F_TBL_TYPE;
                   option = F_O_MODE;
                   }
                else if (Midas_flag == -1)
		   goto next_step;
                else
                   {
                   ftype = F_FTBL_TYPE;
                   option = F_FO_MODE;
                   }

                nz += 3; i = F_TRANS;
	        tfn = newfn('T',"");
	        istat = TCTINI(tfn,i,option,nz,bfdef->data[1].naxis,&mfd);
                /* 
                printf("fitsrhd-2: TCTINI(%s,...), istat = %d\n",tfn,istat);
                */
                if (istat != ERR_NORMAL) return (-999);
 
                for (nr=0; nr<72; nr++) line[nr] = ' '; line[nr] = '\0';
                xSCDWRC(mfd,"IDENT",1,line,1,72,unit);
 
	        for (nr=0; nr<7; nr++) fdd[nr] = 0.0;
	        xSCDWRD(mfd,"O_TIME",fdd,1,7,unit);
                break;

               default     :
	        return htype;
               }

	    mdb_get(mfd);
           next_step:
            bfdef->cflag = -9;		/* mark successful frame creation */
            if (second_time == 1) 
               goto after_loop;		/* skip keyword loop */
            }

         }					/* end of for loop */

      } while (ktype);			/* end of main (do) loop */
   }




after_loop:
if ((bfdef->extname[0] != '\0') && (0 <= mfd))
   {					/* extension name => descr. EXTNAME */
   (void) strncpy(line,bfdef->extname,16);	/* max. 16 chars */
   line[16] = '\0';
   SCDWRC(mfd,"EXTNAME",1,line,1,(int)strlen(line),unit);
   }
 

if (mfd >= 0)
   SCDWRC(mfd,"IDENT",1,bfdef->ident,1,(int)strlen(bfdef->ident),unit);

if (bfdef->naxis && 0<=mfd) 
   {				/* update file descriptors if exist  */
   switch (htype)
      {
      case RGROUP  :
       if (bfdef->pcount && 0<=mfdt) 
          {
          pm = bfdef->parm;
          for (nr=0; nr<bfdef->pcount; nr++) 
             {
             TCCINI(mfdt,D_R8_FORMAT,1,"E15.5"," ",pm->ptype,&nz);
             pm++;
             }
          }

      case IMAGE   :
      case BFITS   :
       if (nfz && fmt=='O') 
          {				 /* check data-format of file   */
          if (bfdef->sflag) 
             {
             float  eps = 10.0e-30;

	     if (uns32 == 1)
                xtype = D_R8_FORMAT;
/*
printf("dtype = %d, bfdef->bzero = %lf, bfdef->bscale = %f\n",
dtype,bfdef->bzero,bfdef->bscale);
*/

             else if ( (dtype == D_I2_FORMAT) && 
                  (fabs(bfdef->bzero-32768.0) < eps) &&
	          (fabs(bfdef->bscale-1.0) < eps) )
                {
		xtype = D_UI2_FORMAT;
		bfdef->bitpix = -16;
		bfdef->sflag = 0;
	        }
	     else
                xtype = D_R4_FORMAT;
	     }
          else switch (bfdef->bitpix)
             {
             case   8 : xtype = D_I1_FORMAT; break;
             case  16 : xtype = D_I2_FORMAT; break;
             case  32 : xtype = D_I4_FORMAT; break;
             case -32 : xtype = D_R4_FORMAT; break;
             case -64 : xtype = D_R8_FORMAT; break;
             default  : return htype;
             }
          if (dtype!=xtype) dtype = xtype;
          }

       if (Midas_flag == 1)
          option = 0;
       else
          option = nfz;

       SCFMOD(mfd,dtype,option);	/* change data type if necessary */


       /* copy CTYPEi to CUNIT+n */

       nz = 16 * (bfdef->naxis + 1);
       memset((void *)ccunit,32,(size_t) nz);
       m = (int) strlen(bfdef->bunit);
       if (m > 0) (void) memcpy(ccunit,bfdef->bunit,(size_t)m);
       istat = n = 0;
       for (i=0; i<bfdef->naxis; i++)
          {
          n += 16;
          m = (int) strlen(bfdef->data[i].ctype);
          if (m > 0)			/* copy CTYPEi to CUNIT+n */
             memcpy(ccunit+n,bfdef->data[i].ctype,(size_t)m);
          }

       if (delt_flag == 1) 
          {
          (void) SCKRDI("MID$MODE",6,1,&istat,&n,unit,unit);
          if (n != 0) delt_flag = 2;		/* ignore the CDELTi ... */
          }
			       /* see, if CDELTi in FITS header */
       if ((delt_flag != 1) && (bfdef->naxis > 1))
          {
          double rotang[2];

          i = get_cdelt(mfd,&dx,&dy,rotang);	/* try to use CD matrix */
          if (i != 0)				/* no CDi_j found... */
             {	
             if (delt_flag == 0)
                {
                SCTMES(M_BLUE_COLOR,
                "no CDELTi nor CDi_j matrix found... STEPi set to 1.0");
                bfdef->data[0].cdelt = 1.0;
                bfdef->data[1].cdelt = 1.0;
                (void) strcpy(helptext,"set to default (= 1.0) ...");
                }
             else			/* delt_flag = 2, but no CDi_j found */
                {
                (void) strcpy(helptext,"from CDELTi");
                }
             }
          else
             {
             SCDWRD(mfd,"ROTANG_FROM_CD-MATRIX",rotang,1,2,unit);
             bfdef->data[0].cdelt = dx;
             bfdef->data[1].cdelt = dy;
             (void) strcpy(helptext,"computed from CD matrix");
             }
          }

       else
          (void) strcpy(helptext,"from CDELTi");	/* set to old default */

       for (i=0; i<bfdef->naxis; i++)
          {					/* compute start pixel */
          ad = &bfdef->data[i]; 
          fdc[i] = ad->crval - (ad->crpix-1.0) * ad->cdelt;
          fdd[i] = bfdef->data[i].cdelt;
          fda[i] = bfdef->data[i].crpix;
          }
       SCDWRD(mfd,"START",fdc,1,bfdef->naxis,unit);
       SCDHWD(mfd,"STEP",fdd,1,bfdef->naxis,unit,helptext);
       SCDWRD(mfd,"REFPIX",fda,1,bfdef->naxis,unit);
       if (bfdef->crflag == 1)			/* old FITS files with CROTA */
          {
          for (i=0; i<bfdef->naxis; i++) fdb[i] = bfdef->data[i].crota;
          SCDWRD(mfd,"ROTA",fdb,1,bfdef->naxis,unit);
          }
 
       SCDWRC(mfd,"CUNIT",1,ccunit,1,nz,unit);
       if (bfdef->mflag==3)
          {
	  ff[0] = bfdef->dmin; ff[1] = bfdef->dmax;
	  SCDWRR(mfd,"LHCUTS",ff,3,2,unit);
	  }
       n = (int) strlen(bfdef->extname);
       if (n > 0) 
          {
          if (n > 16) n = 16;
          memcpy((void *)line,bfdef->extname,(size_t)n);
          for (nr=n; nr<16; nr++) line[nr] = ' '; 
          line[16] = '\0';
          SCDWRC(mfd,"EXTNAME",1,line,1,16,&i);
          }
       break;

      case ATABLE  :
      case BTABLE  :
           for (nr=0; nr<txd->tfields; nr++) 
              {
	      fc = &txd->col[nr];
	      nrep = (0<fc->trepn) ? fc->trepn : 1;
	      nrep *= fc->tncpf;
	      if (!(*fc->tdisp)) strcpy(fc->tdisp,fc->tform);
	      switch (fc->tdfmt) 
                 {
                 case 'A' :
                 case 'L' :
                  if (*fc->tdisp!='A') strcpy(fc->tdisp,fc->tform);
                  break;

                 case 'B' :
                 case 'S' :
                 case 'I' :
                  if (fc->sflag) 
                     {
		     if (*fc->tdisp!='F' && *fc->tdisp!='E' &&
		     *fc->tdisp!='D' && *fc->tdisp!='G')
		     (void) strcpy(fc->tdisp,"E15.5");
		     }
		  else 
                     {
		     if (*fc->tdisp!='I') strcpy(fc->tdisp,fc->tform);
		     }
                  break;

                 case 'X' :
                 case 'P' :
                  if (*fc->tdisp!='I') strcpy(fc->tdisp,fc->tform);
                  break;

                 default  :
                  if (*fc->tdisp!='F' && *fc->tdisp!='E' &&
		      *fc->tdisp!='D' && *fc->tdisp!='G')
		  (void) strcpy(fc->tdisp,fc->tform);
                  break;
		  }

             switch (fc->tdfmt) 
                  {
                  case 'A' :
                       TCCINI(mfd,D_C_FORMAT,nrep*fc->twdth,fc->tdisp,
                              fc->tunit,fc->ttype,&nz);
                       break;
                  case 'L' :
                       TCCINI(mfd,D_C_FORMAT,nrep,fc->tdisp,
                              fc->tunit,fc->ttype,&nz);
                       break;
                  case 'I' :
                       if (fc->sflag)
			 TCCINI(mfd,D_R4_FORMAT,nrep,fc->tdisp,
				fc->tunit,fc->ttype,&nz);
                       else TCCINI(mfd,D_I4_FORMAT,nrep,fc->tdisp,
				   fc->tunit,fc->ttype,&nz);
                       break;
                  case 'E' : 
                       TCCINI(mfd,D_R4_FORMAT,nrep,fc->tdisp,
                              fc->tunit,fc->ttype,&nz);
                       break;
                  case 'D' :
                       TCCINI(mfd,D_R8_FORMAT,nrep,fc->tdisp,
                              fc->tunit,fc->ttype,&nz);
                       break;
                  case 'S' :
                       if (fc->sflag)
			 TCCINI(mfd,D_R4_FORMAT,nrep,fc->tdisp,
				fc->tunit,fc->ttype,&nz);
                       else TCCINI(mfd,D_I2_FORMAT,nrep,fc->tdisp,
				   fc->tunit,fc->ttype,&nz);
                       break;
                  case 'B' :
                       if (fc->sflag)
			 TCCINI(mfd,D_R4_FORMAT,nrep,fc->tdisp,
				fc->tunit,fc->ttype,&nz);
                       else TCCINI(mfd,D_I2_FORMAT,nrep,fc->tdisp,
				   fc->tunit,fc->ttype,&nz);
                       break;
                  case 'X' :
                       nz = (nrep-1)/8 + 1;
                       TCCINI(mfd,D_I1_FORMAT,nz,fc->tdisp,
                              fc->tunit,fc->ttype,&nz);
                       break;
                  case 'C' : 
                       TCCINI(mfd,D_R4_FORMAT,nrep,fc->tdisp,
                              fc->tunit,fc->ttype,&nz);
                       break;
                  case 'M' :
                       TCCINI(mfd,D_R8_FORMAT,nrep,fc->tdisp,
                              fc->tunit,fc->ttype,&nz);
                       break;
                  case 'P' :
                       TCCINI(mfd,D_I4_FORMAT,nrep,fc->tdisp,
			      fc->tunit,fc->ttype,&nz);
                       break;
                  }
           }
        break;
      }
   }

else 
   {                          /* compute size of unknown extension */
   nfz = 1;
   for (i=0; i<bfdef->naxis ; i++) nfz *= bfdef->data[i].naxis;
   nfz = (bfdef->naxis) ? bfdef->gcount*(nfz + bfdef->pcount) : 0;
   i = (bfdef->bitpix<0) ? -bfdef->bitpix/8 : bfdef->bitpix/8;
   *psize = i * nfz;

   switch (htype) 
      {
      case IMAGE   :
      case BFITS   : ftype = (bfdef->mflag==F_FIT_TYPE) ? 
                                 F_FIT_TYPE : F_IMA_TYPE;
	             break;
      case ATABLE  :
      case BTABLE  : ftype = F_TBL_TYPE; break;
      }
   }


if ((save_name == 1) ||
    ((0<bfdef->naxis || hist=='A') && 0<popt && popt<3))
   {					/* print file Ident., etc. */
   switch (htype) 
      {
      case IMAGE  :
      case BFITS  :
      case RGROUP :
       if (ftype == F_IMA_TYPE) 
          {
          istat = CGN_COPY(outnam,newfn('I',(char *) 0));
          if (save_name == 1)			/* here from indisk/mfits? */
             {
             (void) strcat(outnam,".bdf");
             (void) SCKWRC("F$OUTNAM",1,outnam,1,(istat+4),unit);
             outnam[istat] = '\0';		/* remove type again */
             }
          if (popt < 1) break;
             
          if (bfdef->naxis == 0)
             {
             if ((outnam[istat-1] == '0') && (outnam[istat-2] == '0'))
                (void) sprintf(line,
	            "EFH   %-16.16s : empty primary FITS header (NAXIS=0)",
                    outnam);
             else
                (void) sprintf(line,
	            "EFH   %-16.16s : empty FITS header (NAXIS=0)",
                    outnam);
             SCTPUT(line);
             }
          else
             {
             if (bfdef->cflag == 0) break;	/* no frame was created */

             (void) sprintf(line,
              "Image %-16.16s : %-16.16s , naxis: %2d, pixels: %8d, %5d",
              outnam,bfdef->ident,bfdef->naxis,
              bfdef->data[0].naxis,bfdef->data[1].naxis);
             SCTPUT(line);
             }
          if (popt<2) break;			/* no more printing */

          for (i=0; i<bfdef->naxis; i++) 
             {
             ad = &bfdef->data[i];
             (void) sprintf(line,"      naxis  %3d : %6d, %10.2f %10.2f %-16s",
                        i+1,ad->naxis,
                        ad->crval-(ad->crpix-1.0)*ad->cdelt,ad->cdelt,
			ad->ctype);
             SCTPUT(line);
	     }
          }
       else if (ftype == F_FIT_TYPE) 
          {
          istat = CGN_COPY(outnam,newfn('F',(char *) 0));
          if (save_name == 1)			/* here from indisk/mfits? */
             {
             (void) strcat(outnam,".bdf");
             (void) SCKWRC("F$OUTNAM",1,outnam,1,(istat+4),unit);
             outnam[istat] = '\0';              /* remove type again */
             }
          if (popt < 1) break;
             
          (void) sprintf(line,"Fit   %-16.16s : %-16.16s",outnam,bfdef->ident);
          SCTPUT(line);
          }
       break;

      case ATABLE :
      case BTABLE :
       txd = (TXDEF *) bfdef->extd;
       istat = CGN_COPY(outnam,newfn('T',(char *) 0));
       if (save_name == 1)			/* here from indisk/mfits? */
          {
          (void) strcat(outnam,".tbl");
          (void) SCKWRC("F$OUTNAM",1,outnam,1,(istat+4),unit);
          outnam[istat] = '\0';              /* remove type again */
          }
       if (popt < 1) break;
             
       (void) sprintf(line,"Table %-16.16s : %-16.16s , Table r,c: %8d, %5d",
                   outnam,bfdef->ident,bfdef->data[1].naxis,txd->tfields);
       SCTPUT(line);
       if (popt<2) break;

       for (i=0; i<txd->tfields; i++) 
          {
          fc = &txd->col[i];
          (void) sprintf(line,
               "      column %3d : %-16.16s, %-16.16s, %-16.16s",
               i+1,fc->ttype,fc->tform,fc->tunit);
          SCTPUT(line);
          }
       break;

      default : break;
      }
   }

/* check, if descr. with lastchar = '&' still waiting */
i = 0;
n = mdb_cont(mfd,-1,(char *)0,(char *)0);
if (n == -1)
   {                            /* write out this descr. */
   n =  mdb_cont(mfd,3,"dummy","dummy");
   if (n != ERR_NORMAL) return (-9);
   }

if (0 <= mfd) *pmfd = mfd;
if (0 <= mfdt) *pmfdt = mfdt;

text_close();
last_htype = htype;		/* save htype in case we need a 2nd run... */
return htype;
}
/*

*/

/* we use the CD matrix to calculate the old fashioned CDELTi values
   according to the paper "Representation of celestial coords in FITS"
   by M. Calabretta & E. Greisen, A&A 395, page 1102 */

int get_cdelt(imno,dx,dy,rotang)
int    imno;
double *dx, *dy, *rotang;

{
int  iav1, iav2, iav3, iav4, unit=0, null=-1;
int      eco, elo, edi;

int  SCTMES();

double  cdmat11, cdmat12, cdmat21, cdmat22;
double  dw, cdw, roa, rob, ro, eps = 0.1e-8;
/* double  Pi=3.14159265350*/ 
double  twoPi=6.28318530710, Pihalf=1.57079632675;
double aarg(), cos();




eco = ERRO_CONT;
elo = ERRO_LOG;
edi = ERRO_DISP;
ERRO_CONT = 1;        /* disable SC-error handling   */
ERRO_LOG = ERRO_DISP = 0;
   		/* instead of: n = 1; i = 0; SCECNT("PUT",&n,&i,&i); */

cdmat11 = cdmat12 = cdmat21 = cdmat22 = 0;
(void) SCDRDD(imno,"CD1_1",1,1,&iav1,&cdmat11,&unit,&null);
(void) SCDRDD(imno,"CD1_2",1,1,&iav2,&cdmat12,&unit,&null);
(void) SCDRDD(imno,"CD2_1",1,1,&iav3,&cdmat21,&unit,&null);
(void) SCDRDD(imno,"CD2_2",1,1,&iav4,&cdmat22,&unit,&null);

ERRO_CONT = eco;		/* reset */
ERRO_LOG = elo;
ERRO_DISP = edi;
		/* instead of: n = 1; i = 0; SCECNT("PUT",&i,&n,&n); */


iav1 += (iav2 + iav3 + iav4);
if (iav1 == 0) return (1);		/* no CD matrix found */

/*
   dx = sqrt((cdmat11*cdmat11) + (cdmat12*cdmat12));
   dy = sqrt((cdmat21*cdmat21) + (cdmat22*cdmat22));
   if (cdmat11 < 0.0) dx = -dx;
   if (cdmat22 < 0.0) dy = -dy;
*/

if (cdmat21 > 0)
   roa = aarg(cdmat11,cdmat21);
else if (cdmat21 < 0)
   roa = aarg(-cdmat11,-cdmat21);
else
   roa = 0.0;
if (cdmat12 > 0)
   rob = aarg(-cdmat22,cdmat12);
else if (cdmat12 < 0)
   rob = aarg(cdmat22,-cdmat12);
else
   rob = 0.0;

if ((roa - rob) > 0.001)
   {				/* axes are not orthogonal... */
   char  text[80];

   (void) sprintf(text,"rot-long = %lf, rotlat = %lf - axes not orthogonal!",
                  roa,rob);
   SCTMES(M_MAGNT_COLOR,text);            /* display warning */
   }

ro = (roa + rob)/2;


/* check rotation angle */

if (ro > twoPi)
   ro -= twoPi;
else if (ro < -twoPi) 
   ro += twoPi;

cdw = cos(ro);
if (cdw < eps)			/* ro = multiple of 90 degrees */
   {
   if (ro > 0.0)
      {
      if ((ro - Pihalf) < 0.1)
         {				/* +90 deg rotation */
         *dx = cdmat21;
         *dy = cdmat12;
         }
      else
         {				/* +270 = -90 deg rotation */
         *dx = cdmat12;
         *dy = cdmat21;
         }
      }
   else
      {
      ro = -ro;
      if ((ro - Pihalf) < 0.1)
         {				/* -90 deg rotation */
         *dx = cdmat12;
         *dy = cdmat21;
         }
      else
         {				/* -270 = +90 deg rotation */
         *dx = cdmat21;
         *dy = cdmat12;
         }
      }
   }
else
   {
   dw = 1.0/cdw;
   *dx = cdmat11 * dw;
   *dy = cdmat22 * dw;
   }


/*
printf("CD1_1 = %20.12g\nCD1_2 = %20.12g\nCD2_1 = %20.12g\nCD2_2 = %20.12g\n",
cdmat11, cdmat12, cdmat21, cdmat22);
printf("ra = %lf, rb = %lf, angle = %lf (in radians), cos(ro) = %lf\n",
roa,rob,ro,cdw);
printf("get_cdelt: cdelt[0] = %20.12g, cdelt[1] = %20.12g\n",*dx,*dy);
*/

*rotang++ = roa;
*rotang = rob;

return 0;
}

/*

*/

double aarg(xx,yy)
double xx, yy;

{
double  dval;
double Pi=3.1415926535;



if (xx > 0)
   dval = atan2(yy,xx);
else if (xx < 0)
   {
   if (yy < 0)
      dval = atan2(yy,xx) - Pi;
   else
      dval = atan2(yy,xx) + Pi;
   }
else
   {
   if (yy < 0)
      dval = -Pi/2;
   else
      dval = Pi/2;
   }

return dval;
}

