* Last processed by NICE on 12-Jun-2000 15:51:00
* Customized for :  IEEE, LINUX, UNIX, MOTIF, F77
      SUBROUTINE WRITE_SOURCE(ERROR)
C------------------------------------------------------------------------------
C PSC
C	Write and format source information
C------------------------------------------------------------------------------
      LOGICAL ERROR
      INCLUDE 'description.inc'
      INCLUDE 'psc.inc'
      INCLUDE 'inc:pi.inc'
*
      INTEGER I
      CHARACTER CHRA*13,CHDE*13
      REAL*8 LII,BII,DRA,DDEC
      INTEGER ENTIER(4),ENT1,CAT_NUM
*
      INTEGER MAXCAT
      PARAMETER (MAXCAT= 41)             ! Maximum catalog number used in identifications
      CHARACTER*40 CATALOG(MAXCAT+1)
*
* Data statements
      DATA CATALOG/
     $'General Catalog Variable Stars',
     $'Dearborn (Faint Red Stars)',
     $'AFGL (=CRL, =AFCRL) Revised',
     $'IRC 2 Micron Sky Survey',
     $'Wesselius Globules (unpublished)',
     $'R C 2 De Vaucouleurs (Bright Galaxies)',
     $'Emission Lines Stars',
     $'Equatorial Infrared Catalog',
     $'UPPSALA Galaxy Catalog',
     $'Morphological Catalog of Galaxies',
     $'Planetary Nebula Strasbourg',
     $'Zwicky (Galaxies and Clusters)',
     $'SAO',
     $'ESO/UPPSALA Galaxy Catalog',
     $'Bright Stars (HR)',
     $'Suspected Variable Stars',
     $'Cool Carbon Stars',
     $'Gliese (Nearby Stars)',
     $'S Stars',
     $'Parkes HII regions',
     $'Bonn HII regions',
     $'Blitz (CO velocity in HII regions)',
     $'Lynds + ... (Nebulosities)',
     $'IRC with good positions',
     $'Dwarf Galaxies',
     $'Peculiar Galaxies (Arp)',
     $'Markarian (Galaxies with UV)',
     $'Strong 5 GHz (> 1 Jy)',
     $'Veron-Veron (Quasars and Active Nuclei)',
     $'Zwicky (Galaxies)',
     $'Interacting Galaxies (Vorontsov-Vel.)',
     $'IRAS small scale structure',
     $'Reserved for internal use',
     $'Reserved for internal use',
     $'Reserved for internal use',
     $'Reserved for internal use',
     $'Reserved for internal use',
     $'Reserved for internal use',
     $'Ohio (Kraus) radio survey',
     $'Michigan Spectral Survey (stars)',
     $'IRAS Serendipitous Survey Catalog',
     $'?????'/
*
* Write source information
      DRA  = DBLE(RA)
      DDEC = DBLE(DEC)
      CALL SEXAG(CHRA,DRA,24)
      CALL SEXAG(CHDE,DDEC,360)
      CALL EQ1950_TO_GAL(DRA,DDEC,LII,BII,1)
      DO I=1,4
         ENTIER(I) = RELUNC(I)
         ENTIER(I) = ENTIER(I)+128
      ENDDO
      ENT1 = CIRR3
      ENT1 = ENT1 + 127
*
      WRITE (LIST_LUN, 200, ERR=99)
     $CHRA, CHDE, LII*180.D0/PI, BII*180.D0/PI,
     $MAJOR, MINOR, POSANG,
     $NHCON, NLRS, LRSCHAR, VAR, DISC,
     $CONFUSE, PNEARH, PNEARW,
     $HSDFLAG, CIRR1, CIRR2, ENT1, NID, IDTYPE,
     $FLUX(1),FQUAL(1),ENTIER(1),TSNR(1),CC(1),SES1(1),SES2(1),
     $FLUX(2),FQUAL(2),ENTIER(2),TSNR(2),CC(2),SES1(2),SES2(2),
     $FLUX(3),FQUAL(3),ENTIER(3),TSNR(3),CC(3),SES1(3),SES2(3),
     $FLUX(4),FQUAL(4),ENTIER(4),TSNR(4),CC(4),SES1(4),SES2(4)
      RETURN
*
      ENTRY WRITE_IDENTIFICATION (ERROR)
C-------------------------------------------------------------------------------
C PSC
C	Decodes and format information for one identification
C-------------------------------------------------------------------------------
      CAT_NUM = CATNO
      CAT_NUM = MAX(1,MIN(CAT_NUM,MAXCAT+1))
      WRITE (LIST_LUN,140, ERR=99) CATNO, SOURCE,
     $TYPE, RADIUS, POS, FIELD1, FIELD2, FIELD3,
     $CATALOG(CAT_NUM)
      RETURN
*
99    ERROR = .TRUE.
      RETURN
*
* Formats
140   FORMAT(1X,
     $I2,1X,                             ! Catalog number
     $A15,1X,                            ! Source name
     $A5,1X,                             ! Source type
     $I3,1X,                             ! Radius to association
     $I3,1X,                             ! Position angle to association
     $I4,1X,                             ! Field 1
     $I4,1X,                             ! Field 2
     $I4,2X,                             ! Field 3
     $A                                  ! Catalog name
     $)
200   FORMAT (
     $/,
     $1X, '*',1X, A, 1X, A, 3X, F9.4, 1X, F9.4,
     $5(1X,I4), 2X,A2, 2X,I4,
     $2(2X,Z1.1), 2(2X,I1), 2X,Z1.1, 3(2X,I3),  2(1X,I2),
     $/,4(2X,E9.3,1X,I1, 1X,I3,1X,I5,1X,I3,1X,I1,1X,I1,'/'))
      END
