Документ взят из кэша поисковой машины. Адрес оригинального документа : http://www.atnf.csiro.au/computing/software/gipsy/sub/gdsd_wfits.shl Дата изменения: Mon Feb 5 07:27:45 2001 Дата индексирования: Fri Jan 16 22:30:36 2009 Кодировка: Поисковые слова: http astrokuban.info astrokuban

SUBROUTINE GDSD_WFITS(FILNAM,KEY,LEVEL,FREC,ERROR)
*@subroutine gdsd_wfits(character,character,integer,character,integer)
*#>gdsd_wfits.dc2
*Subroutine: GDSD_WFITS
*
*Purpose: Write FITS-type descriptor item
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*
*Use: CALL GDSD_WFITS ( file_id, *name, level, record, *error )
*
* file_id = file identifier, CHARACTER
* * name = name of FITS item. If omitted, the keyword
* found in `record' is used. CHARACTER*8
* level = coordinate word specifying the
* substructure to which the FITS
* item belongs. INTEGER
* record = FITS record, consisting of keyword,
* data and comment. The keyword need
* not be present if `name' is specified.
* CHARACTER*80
* * error = error return code INTEGER
*
*Other entries: GDSD_RFITS, GDSD_RINT, GDSD_WINT, GDSD_RREAL, GDSD_WREAL,
* GDSD_RDBLE, GDSD_WDBLE, GDSD_RLOG, GDSD_WLOG,
* GDSD_RCHAR, GDSD_WCHAR.
*
*Updates: 25-May-87 original document
* 14-Dec-89 brought under GPS
*#<

CCC PARAMETER (IS_INT=-45,IS_REAL=-46,IS_DBLE=-47)

CHARACTER*(*) FILNAM
CHARACTER*(*) KEY
CHARACTER*8 KEY_I
INTEGER LEVEL,ERROR,ERROR_I
CHARACTER*80 FREC,FREC_I

LOGICAL PRESENTN,PRESENTC,BOOLER

INTEGER INTVAL,INT_I
REAL REALVAL,REAL_I
DOUBLE PRECISION DBLEVAL,DBLE_I
LOGICAL LOGVAL
CHARACTER*(*) CHARVAL
CHARACTER*5 FTSD_TYPE
CHARACTER*18 CHARVAL_I

PERFORM CHKARG

IF PRESENTC(KEY)
THEN
KEY_I=KEY
ELSE
KEY_I=FREC(1:8)
CIF

FREC_I='FITS '//FTSD_TYPE(FREC)//FREC(11:80)
CALL GDSD_WRITEC(FILNAM,KEY_I,LEVEL,FREC_I,80,1,ND,ERROR)
RETURN

N
N
N >>> GDSD_RFITS <<<
ENTRY GDSD_RFITS(FILNAM,KEY,LEVEL,FREC,ERROR)
*@subroutine gdsd_rfits(character,character,integer,character,integer)
*#>gdsd_rfits.dc2
*Subroutine: GDSD_RFITS
*
*Purpose: Read FITS descriptor item
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*
*Use: CALL GDSD_RFITS ( file_id, *name, level, record, *error )
*
* file_id = file identifier, CHARACTER
* * name = name of FITS item. If omitted, the keyword
* found in `record' is used. CHARACTER*8
* level = coordinate word specifying the
* substructure from which the FITS
* item is to be obtained. If it is not
* present at this level, higher levels are
* inspected until the item is found or proven
* to be not present. INTEGER
* record = FITS record, consisting of keyword,
* data and comment. CHARACTER*80
* * error = error return code, INTEGER
*
*Updates: 25-May-87 original document
* 14-Dec-89 brought under GPS
*#<

PERFORM CHKARG
KEY_I=KEY

CALL GDSD_READC(FILNAM,KEY_I,LEVEL,FREC_I,80,1,ND,ERROR_I)
CALL GDS___CHECK(FREC_I(1:4).EQ.'FITS',-18,ERROR,*RETURN)
FREC=KEY_I//'= '//FREC_I(11:ND)
BOOLER=ERROR_I.GE.0.OR.ERROR_I.EQ.-4
CALL GDS___CHECK(BOOLER,ERROR_I,ERROR,*RETURN)
IF PRESENTN(ERROR)
THEN
ERROR = ERROR_I
CIF
RETURN


*#>gdsd_wxxx.dc2
*Name: GDSD_Wxxx
*
*Purpose: Write FITS data field
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*
*Use: CALL GDSD_Wxxx ( file_id, name, level, value, *error )
*
* xxx can be REAL, DBLE, INT, LOG or CHAR, depending
* upon type of `value'.
*
* file_id = file identifier, CHARACTER
* name = name of FITS item. CHARACTER*8
* level = coordinate word specifying the
* substructure at which the FITS
* item is to be written. INTEGER
* value = variable containing the data for the
* FITS record. Depending on `xxx', the type
* can be REAL, DOUBLE, INTEGER,
* LOGICAL or CHARACTER*(*).
* * error = error return code, INTEGER
*
* If this routine writes to an existing FITS item, only
* the value field is changed; the comment field is not
* affected.
*
*Updates: 25-May-87 original document
* 14-Dec-89 adjusted to GPS
*#<
*#>gdsd_rxxx.dc2
*Name: GDSD_Rxxx
*
*Purpose: Read FITS data field
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*
*Use: CALL GDSD_Rxxx ( file_id, name, level, value, *error )
*
* xxx can be REAL, DBLE, INT, LOG or CHAR, depending
* upon type of `value'.
*
* file_id = file identifier, CHARACTER
* name = name of FITS item. CHARACTER*8
* level = coordinate word specifying the
* substructure from which the FITS
* item is to be obtained. If it is not
* present at this level, higher levels are
* inspected until the item is found or proven
* to be not present. INTEGER
* value = variable receiving the data from the
* FITS record. Depending on `xxx', the type
* can be REAL, DOUBLE, INTEGER,
* LOGICAL or CHARACTER*(*).
* If a number was requested in a different
* format than has been stored in the file,
* it is converted to the requested type
* (integers are rounded) and an error code
* is returned.
* * error = error return code, INTEGER
* -21 : number conversion error
* -22 : incompatible type
* or level where item was found if call
* was succesful.
*
*
*Updates: 25-May-87 original document
* 14-Dec-89 changed to GPS
* 03-Jan-01 eliminated error codes -45, -46 and -47
*#<

N
N >>> GDSD_WINT <<<
N
ENTRY GDSD_WINT(FILNAM,KEY,LEVEL,INTVAL,ERROR)
*@subroutine gdsd_wint(character,character,integer,integer,integer)

*#>gdsd_wint.dc2
*Name: GDSD_WINT
*
*Purpose: See GDSD_Wxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM CHKARG
KEY_I=KEY

WRITE(FREC_I,'(''FITS INT '',I20)',ERR=FMTERR) INTVAL
CALL GDSD_WRITEC(FILNAM,KEY_I,LEVEL,FREC_I,30,1,ND,ERROR_I)
CALL GDS___CHECK(ERROR_I.GE.0,ERROR_I,ERROR,*RETURN)

RETURN

N
N >>> GDSD_RINT <<<
ENTRY GDSD_RINT(FILNAM,KEY,LEVEL,INTVAL,ERROR)
*@subroutine gdsd_rint(character,character,integer,integer,integer)

*#>gdsd_rint.dc2
*Name: GDSD_RINT
*
*Purpose: See GDSD_Rxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM GETREC
IF FREC_I(1:10).EQ.'FITS INT '
- .OR.FREC_I(1:10).EQ.'FITS '
THEN
PERFORM DCINT
ELSE
PERFORM GETNUM
CIF
INTVAL=INT_I
PERFORM CLNUP

RETURN

N
N >>>> GDSD_WREAL <<<<
ENTRY GDSD_WREAL(FILNAM,KEY,LEVEL,REALVAL,ERROR)
*@subroutine gdsd_wreal(character,character,integer,real,integer)

*#>gdsd_wreal.dc2
*Name: GDSD_WREAL
*
*Purpose: See GDSD_Wxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM CHKARG
KEY_I=KEY

WRITE(FREC_I,'(''FITS REAL '',G20.8)',ERR=FMTERR) REALVAL
CALL GDSD_WRITEC(FILNAM,KEY_I,LEVEL,FREC_I,30,1,ND,ERROR_I)
CALL GDS___CHECK(ERROR_I.GE.0,ERROR_I,ERROR,*RETURN)

RETURN

N
N >>>> GDSD_RREAL
N
ENTRY GDSD_RREAL(FILNAM,KEY,LEVEL,REALVAL,ERROR)
*@subroutine gdsd_rreal(character,character,integer,real,integer)

*#>gdsd_rreal.dc2
*Name: GDSD_RREAL
*
*Purpose: See GDSD_Rxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM GETREC
IF FREC_I(1:10).EQ.'FITS REAL '
- .OR.FREC_I(1:10).EQ.'FITS '
THEN
PERFORM DCREAL
ELSE
PERFORM GETNUM
CIF
REALVAL=REAL_I
PERFORM CLNUP

RETURN
N
N >>>> GDSD_WDBLE <<<<
N
ENTRY GDSD_WDBLE(FILNAM,KEY,LEVEL,DBLEVAL,ERROR)
*@subroutine gdsd_wdble(character,character,integer,double precision,integer)

*#>gdsd_wdble.dc2
*Name: GDSD_WDBLE
*
*Purpose: See GDSD_Wxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM CHKARG
KEY_I=KEY

WRITE(FREC_I,'(''FITS DBLE '',D20.14)',ERR=FMTERR) DBLEVAL
CALL GDSD_WRITEC(FILNAM,KEY_I,LEVEL,FREC_I,30,1,ND,ERROR_I)
CALL GDS___CHECK(ERROR_I.GE.0,ERROR_I,ERROR,*RETURN)

RETURN
N
N >>>> GDSD_RDBLE <<<<
N
ENTRY GDSD_RDBLE(FILNAM,KEY,LEVEL,DBLEVAL,ERROR)
*@subroutine gdsd_rdble(character,character,integer,double precision,integer)

*#>gdsd_rdble.dc2
*Name: GDSD_RDBLE
*
*Purpose: See GDSD_Rxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM GETREC
IF FREC_I(1:10).EQ.'FITS DBLE '
- .OR.FREC_I(1:10).EQ.'FITS '
THEN
PERFORM DCDBLE
ELSE
PERFORM GETNUM
CIF
DBLEVAL=DBLE_I
PERFORM CLNUP

RETURN

N
N >>>> GDSD_WLOG <<<<
N
ENTRY GDSD_WLOG(FILNAM,KEY,LEVEL,LOGVAL,ERROR)
*@subroutine gdsd_wlog(character,character,integer,logical,integer)

*#>gdsd_wlog.dc2
*Name: GDSD_WLOG
*
*Purpose: See GDSD_Wxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM CHKARG
KEY_I=KEY

WRITE(FREC_I,'(''FITS LOG '',L20)',ERR=FMTERR) LOGVAL
CALL GDSD_WRITEC(FILNAM,KEY_I,LEVEL,FREC_I,30,1,ND,ERROR_I)
CALL GDS___CHECK(ERROR_I.GE.0,ERROR_I,ERROR,*RETURN)

RETURN

N
N >>>> GDSD_RLOG <<<<
N
ENTRY GDSD_RLOG(FILNAM,KEY,LEVEL,LOGVAL,ERROR)
*@subroutine gdsd_rlog(character,character,integer,logical,integer)

*#>gdsd_rlog.dc2
*Name: GDSD_RLOG
*
*Purpose: See GDSD_Rxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM CHKARG
KEY_I=KEY

CALL GDSD_READC(FILNAM,KEY_I,LEVEL,FREC_I,30,1,ND,ERROR_I)
BOOLER=ERROR_I.GE.0.OR.ERROR_I.EQ.-4
CALL GDS___CHECK(BOOLER,ERROR_I,ERROR,*RETURN)
BOOLER=FREC_I(1:10).EQ.'FITS LOG '
- .OR.FREC_I(1:10).EQ.'FITS '
CALL GDS___CHECK(BOOLER,-22,ERROR,*RETURN)
READ(FREC_I(11:30),'(L20)',ERR=FMTERR) LOGVAL
CALL GDS___CHECK(ERROR_I.GE.0,ERROR_I,ERROR,*RETURN)
IF PRESENTN(ERROR)
THEN
ERROR = ERROR_I
CIF


RETURN

N
N >>>> GDSD_WCHAR <<<<
N
ENTRY GDSD_WCHAR(FILNAM,KEY,LEVEL,CHARVAL,ERROR)
*@subroutine gdsd_wchar(character,character,integer,character,integer)

*#>gdsd_wchar.dc2
*Name: GDSD_WCHAR
*
*Purpose: See GDSD_Wxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM CHKARG
KEY_I=KEY
CHARVAL_I=CHARVAL

WRITE(FREC_I,ERR=FMTERR,
- FMT='(''FITS CHAR '''''',A,'''''''')') CHARVAL_I
CALL GDSD_WRITEC(FILNAM,KEY_I,LEVEL,FREC_I,30,1,ND,ERROR_I)
CALL GDS___CHECK(ERROR_I.GE.0,ERROR_I,ERROR,*RETURN)

RETURN

N
N >>>> GDSD_RCHAR <<<<
N
ENTRY GDSD_RCHAR(FILNAM,KEY,LEVEL,CHARVAL,ERROR)
*@subroutine gdsd_rchar(character,character,integer,character,integer)

*#>gdsd_rchar.dc2
*Name: GDSD_RCHAR
*
*Purpose: See GDSD_Rxxx
*
*File: gdsd_wfits.shl
*
*Category: GDS
*
*Author: J.P. Terlouw
*#<

PERFORM CHKARG
KEY_I=KEY

CALL GDSD_READC(FILNAM,KEY_I,LEVEL,FREC_I,30,1,ND,ERROR_I)
BOOLER=ERROR_I.GE.0.OR.ERROR_I.EQ.-4
CALL GDS___CHECK(BOOLER,ERROR_I,ERROR,*RETURN)
BOOLER=FREC_I(1:10).EQ.'FITS CHAR'
- .OR.FREC_I(1:10).EQ.'FITS '
CALL GDS___CHECK(BOOLER,-22,ERROR,*RETURN)
KEND=INDEX(FREC_I(20:30),'''')+18
READ(FREC_I(12:KEND),'(A)',ERR=FMTERR) CHARVAL_I
CHARVAL=CHARVAL_I
CALL GDS___CHECK(ERROR_I.GE.0,ERROR_I,ERROR,*RETURN)
IF PRESENTN(ERROR)
THEN
ERROR = ERROR_I
CIF

RETURN

PROC GETREC
PERFORM CHKARG
KEY_I=KEY
CALL GDSD_READC(FILNAM,KEY_I,LEVEL,FREC_I,30,1,ND,ERROR_I)
N Short record (-4) allowed
BOOLER = ERROR_I.GE.0.OR.ERROR_I.EQ.-4
CALL GDS___CHECK(BOOLER,ERROR_I,ERROR,*RETURN)
CPROC

PROC GETNUM
IF FREC_I(1:10).EQ.'FITS INT '
THEN
CCC ERROR_I=IS_INT
PERFORM DCINT
REAL_I=INT_I
DBLE_I=INT_I
ELSEIF FREC_I(1:10).EQ.'FITS REAL '
THEN
CCC ERROR_I=IS_REAL
PERFORM DCREAL
INT_I=NINT(REAL_I)
DBLE_I=REAL_I
ELSEIF FREC_I(1:10).EQ.'FITS DBLE '
THEN
CCC ERROR_I=IS_DBLE
PERFORM DCDBLE
INT_I=NINT(DBLE_I)
REAL_I=DBLE_I
ELSE
ERROR_I=-22
CIF
CPROC

PROC CHKARG
ERROR_I=0
CPROC

PROC CLNUP
CALL GDS___CHECK(ERROR_I.GE.0,ERROR_I,ERROR,*RETURN)
IF PRESENTN(ERROR)
THEN
ERROR = ERROR_I
CIF
CPROC

PROC DCINT
READ(FREC_I(11:30),'(BN,I20)',ERR=FMTERR) INT_I
CPROC
PROC DCREAL
READ(FREC_I(11:30),'(BN,F20.0)',ERR=FMTERR) REAL_I
CPROC
PROC DCDBLE
READ(FREC_I(11:30),'(BN,D20.0)',ERR=FMTERR) DBLE_I
CPROC

PROC FMTERR
ERROR_I=-21
CPROC

END