C ++********************************************************************
C                                                                      *
C DECIMATE.F                                                           *
C                  OPFILEC                         FEB 03 ARDEAN LEITH
C                                                                      *
C **********************************************************************
C=* FROM: SPIDER - MODULAR IMAGE PROCESSING SYSTEM.   AUTHOR: J.FRANK  *
C=* Copyright (C) 1985-2005  Health Research Inc.                      *
C=*                                                                    *
C=* HEALTH RESEARCH INCORPORATED (HRI),                                *   
C=* ONE UNIVERSITY PLACE, RENSSELAER, NY 12144-3455.                   *
C=*                                                                    *
C=* Email:  spider@wadsworth.org                                       *
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 the *
C=* 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 GNU  *
C=* General Public License for more details.                           *
C=*                                                                    *
C=* You should have received a copy of the GNU General Public License  *
C=* along with this program; if not, write to the                      *
C=* Free Software Foundation, Inc.,                                    *
C=* 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.      *
C=*                                                                    *
C **********************************************************************
C                                                                      *
C  DECIMATE(MAXMEM)
C                                                                      *
C23456789012345678901234567890123456789012345678901234567890123456789012
C***********************************************************************

	SUBROUTINE  DECIMATE

	INCLUDE 'CMBLOCK.INC'
        INCLUDE 'CMLIMIT.INC' 
 
        CHARACTER(LEN=MAXNAM)   ::  FINPIC
	CHARACTER*1   NULL
	REAL, ALLOCATABLE, DIMENSION(:) ::  Q,W

	DATA  INPIC/98/,IOPIC/97/

	NULL = CHAR(0)

	MAXIM = 0
        CALL OPFILEC(0,.TRUE.,FINPIC,INPIC,'O',IFORM,NSAM,NROW,NSLICE,
     &             MAXIM,'INPUT',.FALSE.,IRTFLG)

	CALL FILERD(FINPIC,NLETI,NULL,'OUTPUT',IRTFLG)

	CALL RDPRMI(MX,MY,NOT_USED,'DECIMATION FACTORS X, Y')

	IF (IFORM .EQ. 3) THEN
	   CALL RDPRMI(MZ,IDUM,NOT_USED,'DECIMATION FACTOR Z')
	ELSE
	   MZ     = 1
	   NSLICE = 1
	ENDIF

	NSAMP   = NSAM/MX
	NROWP   = NROW/MY
	NSLICEP = NSLICE/MZ

	IF (NSAMP.LE.0 .OR. NROWP.LE.0 .OR. NSLICEP.LE.0)  THEN
           CLOSE(INPIC)
           CALL  ERRT(36,'DC',NE)
           RETURN
	ENDIF

	MAXIM=0
        CALL  OPFILEC(INPIC,.FALSE.,FINPIC,IOPIC,'U',IFORM,
     &             NSAMP,NROWP,NSLICEP,
     &             MAXIM,NULL,.FALSE.,IRTFLG)
        IF (IRTFLG .NE. 0) RETURN

	ALLOCATE(Q(NSAM),STAT=IRTFLG)
	IF (IRTFLG.NE.0) CALL  ERRT(46,'DC, A',IER)

	IF (FCHAR(4:4).EQ.'S')  THEN
	   ALLOCATE(W(NSAMP),STAT=IRTFLG)
	   IF(IRTFLG.NE.0) CALL  ERRT(46,'DC, W',IER)
	   CALL  DECIMS(INPIC,IOPIC,Q,W,
     &		NSAM,NROW,NSLICE,NSAMP,NROWP,MX,MY,MZ)
	   DEALLOCATE(W)
	ELSE
	   CALL  DECIM(INPIC,IOPIC,Q,
     &		NSAM,NROW,NSLICE,NSAMP,NROWP,MX,MY,MZ)
	ENDIF
	DEALLOCATE(Q)
	CLOSE(INPIC)
	CLOSE(IOPIC)
	END



	SUBROUTINE  DECIMS(INPIC,IOPIC,BI,BO,
     &		NSAM,NROW,NSLICE,NSAMP,NROWP,MX,MY,MZ)

	DIMENSION  BI(NSAM),BO(NSAMP)

	DO    K=1,NSLICE-MZ+1,MZ
	 DO    J=1,NROW-MY+1,MY
	  BO=0.0
	   DO    KT=1,MZ
	     DO    JT=1,MY
	      CALL  REDLIN(INPIC,BI,NSAM,J+JT-1+NROW*(K+KT-2))
	       DO    I=1,NSAM-MX+1,MX
	         DO  IT=0,MX-1
	           BO((I+MX-1)/MX)=BO((I+MX-1)/MX)+BI(I+IT)
	         ENDDO
               ENDDO
             ENDDO
           ENDDO
	  BO=BO/MX/MY/MZ
	 CALL  WRTLIN(IOPIC,BO,NSAMP,(J+MY-1)/MY+NROWP*((K+MZ-1)/MZ-1))
	 ENDDO
	ENDDO
	END	


	SUBROUTINE  DECIM(INPIC,IOPIC,BI,
     &		NSAM,NROW,NSLICE,NSAMP,NROWP,MX,MY,MZ)

	DIMENSION  BI(NSAM)

	DO    K=1,NSLICE-MZ+1,MZ
	 DO    J=1,NROW-MY+1,MY
	 CALL  REDLIN(INPIC,BI,NSAM,J+NROW*(K-1))
	  DO    I=1,NSAM-MX+1,MX
	   BI((I+MX-1)/MX)=BI(I)
          ENDDO
	 CALL  WRTLIN(IOPIC,BI,NSAMP,(J+MY-1)/MY+NROWP*((K+MZ-1)/MZ-1))
	 ENDDO
	ENDDO
	END