C *********************************************************************
c
C  WRTHEDMRC
C
C *********************************************************************
C       WRTHEDMRC IS A MERGER OF ICRHDR AND IWRHDR
C
C       ICRHDR -----------------
C
C	CREATE NEW HEADER. ALL OF THE STANDARD IMAGE DEFAULTS ARE
C	SET UP GIVEN THE REQUESTED INFORMATION. HEADER NOT WRITTEN!!
C NOTE: THE STARTING POINT FOR COLUMNS,ROWS,SECTIONS
C	ARE SET TO 0 BY DEFAULT.!!!!!!!!!
C
C	INXYZ		  : SIZE OF FILE COLUMNS, ROWS, SECTIONS
C	MXYZ		  : # OF INTERVALS COLUMNS, ROWS, SECTIONS
C	IMODE		  : DATA STORAGE MODE (1-4)
C				0 = IMAGE		INTEGER*1
C				1 = IMAGE               INTEGER*2
C				2 = IMAGE               REALS
C				3 = FOURIER TRANSFORM   INTEGER*2
C				4 = FOURIER TRANSFORM   REALS
C	LABELS(20,N)	  :N=1,10 UP TO 10 80 CHARACTER LABELS
C	NL		  :ACTUAL # OF LABELS TO USE (0 IS O.K.)
C
C
C       IWRHDR ---------------
C       THE MRC FILE FORMAT WAS OPENED WITH A RECORD LENGTH OF
C       1024 BYTES. WRITE THE HEADER OF SAME LENGTH THEN NSLICE *
C	NROW * NSAM FLOATS OF THE IMAGE.
C	TITLE IS A SINGLE 80 CHARACTER TITLE.
C
C *********************************************************************

	SUBROUTINE WRTHEDMRC(FILNAM, NSAM, NROW, NSLICE,
     &                  IUNIT,BUF,DMIN,DMAX,DMEAN,MODE,IRTFLG)

        COMMON /UNITS/LUNT,NIN,NOUT

	CHARACTER*80 FILNAM
        REAL         BUF(*) 
	DIMENSION    INXYZ(3),MXYZ(3)
	INTEGER      LABLS(20,10)
	DIMENSION    NCRS(3),CRST(3),NXYZ(3),
     &		     CEL(6),MAPCRS(3),DENMMM(3), ORIGXY(2)  

        REAL         STUFF(31) 
	INTEGER*4    ISTUFF(31)
	EQUIVALENCE  (STUFF,ISTUFF)

        CHARACTER*80 TIT 
        REAL         LABELS(20,10) 
        EQUIVALENCE  (TIT,LABELS)
        CHARACTER*1  NULL
	
        DATA TIT/'SPIDER FILE '/
	DATA NBHDR/1024/, NBW/4/, NBW3/12/, NB/4/
	
	NBL    = 800
	NL     = 1
        IRTFLG = 1
	
c	NOTE: WE WILL ALWAYS COPY IN REAL*4 FORMAT.	
C       IMAGE REAL*4 FORMAT
	
        NXYZ(1)  = NSAM
        NXYZ(2)  = NROW
        NXYZ(3)  = NSLICE
	INXYZ(1) = NSAM
	INXYZ(2) = NROW
	INXYZ(3) = NSLICE

C	0 <= ML <= 10	
C	ML = MIN(NL,10)
C	ML = MAX(ML,0)

C	NLAB = ML
	NLAB = 1
	
C	ORIGIN ON X,Y AXIS 
	IF (MOD(NSAM,2) .NE. 0) THEN
	   ORIGXY(1) = (NSAM/2) + 1
	ELSE
	   ORIGXY(1) = (NSAM/2)
	ENDIF
	IF (MOD(NROW,2).NE.0) THEN
	   ORIGXY(2) = (NROW/2) + 1
	ELSE
	   ORIGXY(2) = (NROW/2)
	ENDIF 
 
 	WRITE(NOUT,*) 'DEFAULT VALUE FOR ORIGIN (+1 IF NSAM, NROW ODD)'
	WRITE(NOUT,*) '(X,Y) = ((NSAM/2) + 1, (NSAM/2) + 1)'
	WRITE(NOUT,*) 'ENTER -9999 IF YOU WANT TO USE DEFAULT VALUES'
	
	CALL RDPRMI(I1,I2,NOT_USED,'ENTER X,Y ORIGIN OF MRC IMAGE')
	IF (I1 .NE. -9999) THEN
	   ORIGXY(1) = I1
	   ORIGXY(2) = I2
	ENDIF
	
	DO  K = 1,3
	  NCRS(K)   = NXYZ(K) 
	  MXYZ(K)   = NXYZ(K) 
	  CEL(K)    = NXYZ(K)
	  CEL(K+3)  = 90.0
	  CRST(K)   = 0.0
	  MAPCRS(K) = K
	  DENMMM(K) = 0.0
	ENDDO
	
	DO J = 1,31
          STUFF(J) = 0.0
	ENDDO

C       SPACE GROUP, # BYTES SYMMETRY 	ISPG = 0 NBSYM = 0
	ISTUFF(1) = 0
	ISTUFF(2) = 0
        
        TIT(12:21) = FILNAM(1:10)
        NULL       = CHAR(0)
	CALL CCFILL(LABLS(1,1),NULL,NBL)
	
 	DENMMM(1) = DMIN 
	DENMMM(2) = DMAX 
	DENMMM(3) = DMEAN
	   
	NBW  = 4
	NBW3 = 12 
	NB   = 4
	NBL  = 800  

C       I = 1
        I=1
        CALL CCPMVI(BUF(I),NCRS,NBW3/4)
	I= I + NBW3/4

C       I = 4		
        CALL CCPMVI(BUF(I),MODE,NBW/4)
	I= I + NBW/4

C       I = 5
        CALL CCPMVI(BUF(I),CRST,NBW3/4)
	I= I + NBW3/4

C       I = 8	
        CALL CCPMVI(BUF(I),NXYZ,NBW3/4)
	I= I + NBW3/4

C       I = 11	
        CALL CCPMVI(BUF(I),CEL,(NBW*6)/4)
	I= I + (NBW*6)/4

C       I = 17	
        CALL CCPMVI(BUF(I),MAPCRS,NBW3/4)
	I= I + NBW3/4

C       I = 20	
        CALL CCPMVI(BUF(I),DENMMM ,NBW3/4)
	I= I + NBW3/4

C       I = 23	 
        CALL CCPMVI(BUF(I),STUFF,(NBW*31)/4)
	I= I + (NBW*31)/4

C       I = 54
        CALL CCPMVI(BUF(I),ORIGXY,(NBW*2)/4)
	I= I + (NBW*2)/4 

C       I = 56
        CALL CCPMVI(BUF(I),NLAB,NBW/4)
	I= I + NBW/4

C       I = 57	
        CALL CCPMVI(BUF(I),LABLS(1,1),NBL/4)
	I= I + NBL/4 -1

        IF (I .GT. 256) THEN
	   WRITE(NOUT,10)
10 	   FORMAT('*** HEADER IS > 1024 BYTES')
           CALL ERRT(100,'WRTHEDMRC',NE)
           RETURN
	ENDIF
	
C	WRITE HEADER OF 1024 BYTES (256 FLOATS) FLOAT BY FLOAT
	DO IRECT=1, 256
	   WRITE(IUNIT,REC=IRECT,IOSTAT=IERR) BUF(IRECT)
 
           IF (IERR .NE. 0) THEN
              WRITE(NOUT,*)'*** ERROR WRITING HEADER ELEMENT: ',IRECT
              CALL ERRT(100,'WRTHEDMRC',NE)
              IRTFLG = 1
              RETURN
           ENDIF
 	ENDDO

	IRTFLG = 0

	RETURN
        END

C -----------------------------------------------------------

      SUBROUTINE CCFILL(ARR1,SCAL,NTIMES)

C PARAMETERS:
C      ARR1 (I/O)   ARRAY TO WHICH BYTES ARE TO BE COPIED
C      SCAL (I)     BYTE VALUE TO BE COPIED INTO ARR1
C      NTIMES (I)   THE NUMBER OF BYTES TO BE COPIED

      INTEGER NTIMES
      LOGICAL * 1    SCAL
      LOGICAL * 1    ARR1(*)
      INTEGER        N

      DO N = 1,NTIMES
        ARR1(N) = SCAL
      ENDDO

      RETURN
      END