C                  INTERNATIONAL AVS CENTER
C        (This disclaimer must remain at the top of all files)
C
C WARRANTY DISCLAIMER
C
C This module and the files associated with it are distributed free of charge.
C It is placed in the public domain and permission is granted for anyone to use,
C duplicate, modify, and redistribute it unless otherwise noted.  Some modules
C may be copyrighted.  You agree to abide by the conditions also included in
C the AVS Licensing Agreement, version 1.0, located in the main module
C directory located at the International AVS Center ftp site and to include
C the AVS Licensing Agreement when you distribute any files downloaded from
C that site.
C
C The International AVS Center, MCNC, the AVS Consortium and the individual
C submitting the module and files associated with said module provide absolutely
C NO WARRANTY OF ANY KIND with respect to this software.  The entire risk as to
C the quality and performance of this software is with the user.  IN NO EVENT
C WILL The International AVS Center, MCNC, the AVS Consortium and the individual
C submitting the module and files associated with said module BE LIABLE TO
C ANYONE FOR ANY DAMAGES ARISING FROM THE USE OF THIS SOFTWARE, INCLUDING,
C WITHOUT LIMITATION, DAMAGES RESULTING FROM LOST DATA OR LOST PROFITS, OR ANY
C SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES.
C
C This AVS module and associated files are public domain software unless
C otherwise noted.  Permission is hereby granted to do whatever you like with
C it, subject to the conditions that may exist in copyrighted materials. Should
C you wish to make a contribution toward the improvement, modification, or
C general performance of this module, please send us your comments:  why you
C liked or disliked it, how you use it, and most important, how it helps your
C work. We will receive your comments at avs@ncsc.org.
C
C Please send AVS module bug reports to avs@ncsc.org.
C
 
C ****************************************
C  Module Specification
C ****************************************
       integer function inner_spec()
       implicit none
C   IAC CODE CHANGE :        include 'avs/avs.inc'
	INCLUDE '/usr/avs/include/avs.inc'

       integer in_port, out_port, param
       external inner_compute
       integer inner_compute

       call AVSset_module_name('glue', 'mapper')
       call AVSset_module_flags(single_arg_data)

C	Input Port Specifications
       in_port = AVScreate_input_port('indata', 
     $  'field', REQUIRED)

C	Output Port Specifications
       out_port = AVScreate_output_port('outdata', 
     $  'field')

C	Parameter Specifications
       param = AVSadd_parameter('autoadd', 'boolean',1,0,1)
       call AVSconnect_widget(param, 'toggle')
       param = AVSadd_parameter('add NOW', 'oneshot', 0, 0, 1)
       call AVSconnect_widget(param, 'oneshot')
       param = AVSadd_parameter('initialize', 'oneshot', 1, 0, 1)
       call AVSconnect_widget(param, 'oneshot')
       param = AVSadd_parameter('total sets', 'integer', 0, 0, 1)
       call AVSconnect_widget(param, 'typein_integer')
       param = AVSadd_parameter('dimension', 'integer', 1,1,1)
       call AVSconnect_widget(param, 'idial')

       call AVSset_compute_proc(inner_compute)
C ----> START OF USER-SUPPLIED CODE SECTION #2 (ADDITIONAL SPECIFICATION INFO)
C <---- END OF USER-SUPPLIED CODE SECTION #2
       inner_spec = 1
       return
       end
 
C ****************************************
C Module Compute Routine
C ****************************************
       integer function inner_compute(indata, outdata,
     +         autoadd,addnow,initialize,total,dimension)
       implicit none
C   IAC CODE CHANGE :        include 'avs/avs.inc'
	INCLUDE '/usr/avs/include/avs.inc'
       integer indata, outdata
       integer autoadd, addnow, initialize, total
       integer dimension

C ----> START OF USER-SUPPLIED CODE SECTION #3 (COMPUTE ROUTINE BODY)

C Input Field

      BYTE    bi(1)
      INTEGER ii(1)
      REAL*4  ri(1)
      REAL*8  di(1)
      INTEGER dimsi(3), ifield
      INTEGER ndimi, vecleni
      INTEGER datatype, datatypeo
C Temp Field
      BYTE    bt(1)
      INTEGER it(1)
      REAL*4  rt(1)
      REAL*8  dt(1)
      INTEGER dimst(4), tfield
      INTEGER tempdata

C template field
      INTEGER template

C Output Field
      BYTE    bo(1)
      INTEGER io(1)
      REAL*4  ro(1)
      REAL*8  do(1)
      INTEGER dimso(4), ofield
      INTEGER ndimo, vecleno

      INTEGER iresult
      INTEGER outsize, insize
      INTEGER i, flags
      INTEGER imax, it_fits

      ndimi   = AVSfield_get_int(indata, avs_field_ndim)
      vecleni = AVSfield_get_int(indata, avs_field_veclen)
      datatype = AVSfield_get_int(indata, avs_field_type)
      iresult = AVSfield_get_dimensions(indata, dimsi)

      IF (datatype.EQ.0) THEN
        iresult = AVSfield_data_offset(indata, bi, ifield)
      ELSEIF (datatype.EQ.1) THEN
        iresult = AVSfield_data_offset(indata, ii, ifield)
      ELSEIF (datatype.EQ.2) THEN
        iresult = AVSfield_data_offset(indata, ri, ifield)
      ELSEIF (datatype.EQ.3) THEN
        iresult = AVSfield_data_offset(indata, di, ifield)
      ENDIF

      DO i = ndimi+1, 3
	dimsi(i) = 1
      ENDDO

      IF (initialize) THEN

        IF (outdata .ne. 0) CALL AVSfield_free(outdata)
	outdata = 0
	call AVSmark_output_unchanged('outdata')
	call AVSmodify_parameter('total sets',
     +	                         IOR(avs_minval,IOR(avs_value,avs_maxval)
     $),
     +                           0,0,0)
        CALL AVSmodify_parameter('dimension',avs_maxval,1,1,ndimi+1)

      ELSEIF (autoadd.or.addnow) THEN

        IF (outdata.EQ.0) THEN

	  DO i = 1, ndimi
	    dimso(i) = dimsi(i)
	  ENDDO

	  DO i = ndimi+1, 4
	    dimso(i) = 1
	  ENDDO

          iresult = AVSfield_make_template(indata, template)

          datatypeo = datatype
          ndimo = ndimi
	  IF (dimension.EQ.ndimi+1) THEN
	    ndimo = ndimi + 1
            iresult = AVSfield_set_int(template,avs_field_ndim,ndimo)
	  ENDIF

	  outdata = AVSfield_alloc(template, dimso)

	  IF (datatype.EQ.0) THEN
            iresult = AVSfield_data_offset(outdata, bo, ofield)
	  ELSEIF (datatype.EQ.1) THEN
            iresult = AVSfield_data_offset(outdata, io, ofield)
	  ELSEIF (datatype.EQ.2) THEN
            iresult = AVSfield_data_offset(outdata, ro, ofield)
	  ELSEIF (datatype.EQ.3) THEN
            iresult = AVSfield_data_offset(outdata, do, ofield)
	  ENDIF

          imax = vecleni
	  DO i = 1, ndimi
	    imax = imax*dimsi(i)
	  ENDDO

          IF (datatype.EQ.0) THEN
	    DO i = 1, imax
	      bo(ofield+i) = bi(ifield+i)
            ENDDO
          ELSEIF (datatype.EQ.1) THEN
	    DO i = 1, imax
	      io(ofield+i) = ii(ifield+i)
            ENDDO
          ELSEIF (datatype.EQ.2) THEN
	    DO i = 1, imax
	      ro(ofield+i) = ri(ifield+i)
            ENDDO
          ELSEIF (datatype.EQ.3) THEN
	    DO i = 1, imax
	      do(ofield+i) = di(ifield+i)
            ENDDO
	  ENDIF

	  call AVSmodify_parameter('total sets',
     +                            IOR(avs_minval,IOR(avs_value,avs_maxva
     $l)),
     +                             1,1,1)

	ELSE

          iresult = AVSfield_get_dimensions(outdata, dimso)
	  IF (datatypeo.EQ.0) THEN
            iresult = AVSfield_data_offset(outdata, bo, ofield)
	  ELSEIF (datatypeo.EQ.1) THEN
            iresult = AVSfield_data_offset(outdata, io, ofield)
	  ELSEIF (datatypeo.EQ.2) THEN
            iresult = AVSfield_data_offset(outdata, ro, ofield)
	  ELSEIF (datatypeo.EQ.3) THEN
            iresult = AVSfield_data_offset(outdata, do, ofield)
	  ENDIF
          vecleno = AVSfield_get_int(outdata, avs_field_veclen)

	  DO i = ndimo+1, 4
	    dimso(i) = 1
	  ENDDO
	
	  it_fits = 1

	  DO i = 1, ndimi
	    IF (i.NE.dimension.AND.dimso(i).NE.dimsi(i)) THEN
	      it_fits = 0
	      call AVSwarning('input data dimensions wrong - must form a *recta
     $ngle*')
	    ENDIF
	    IF (dimension.LE.ndimi.AND.ndimo.GT.ndimi) THEN
	      it_fits = 0
	      call AVSwarning('input data does not have enough dimensions')
            ENDIF
	    IF (vecleno.NE.vecleni) THEN
	      call AVSwarning('input data does not match output vector length')
	      it_fits = 0
            ENDIF
	    IF (datatypeo.NE.datatype) THEN
	      call AVSwarning('input data type does not match ouput data type')
	      it_fits = 0
            ENDIF
	  ENDDO

	  IF (it_fits) THEN

            DO i = 1, ndimo
	      dimst(i) = dimso(i)
	    ENDDO
            DO i = ndimo+1, 4
	      dimst(i) = 1
	    ENDDO

	    IF (dimension.GT.ndimi) THEN
	      dimst(dimension) = dimso(dimension) + 1
	    ELSE
	      dimst(dimension) = dimso(dimension) + dimsi(dimension)
	    ENDIF

            iresult = AVSfield_make_template(outdata, template)
	    tempdata = AVSfield_alloc(template, dimst)

	    IF (datatype.EQ.0) THEN
              iresult = AVSfield_data_offset(tempdata, bt, tfield)
	    ELSEIF (datatype.EQ.1) THEN
              iresult = AVSfield_data_offset(tempdata, it, tfield)
	    ELSEIF (datatype.EQ.2) THEN
              iresult = AVSfield_data_offset(tempdata, rt, tfield)
	    ELSEIF (datatype.EQ.3) THEN
              iresult = AVSfield_data_offset(tempdata, dt, tfield)
	    ENDIF

            IF (datatype.EQ.0) THEN
              CALL byte_compute(bt(tfield+1), bo(ofield+1), bi(ifield+1)
     $,
     +                          dimst(1),dimst(2),dimst(3),dimst(4),
     +                          dimso(1),dimso(2),dimso(3),dimso(4),
     +                          dimsi(1),dimsi(2),dimsi(3), vecleni)
            ELSEIF (datatype.EQ.1) THEN
              CALL integer_compute(it(tfield+1), io(ofield+1), ii(ifield
     $+1),
     +                             dimst(1),dimst(2),dimst(3),dimst(4),
     +                             dimso(1),dimso(2),dimso(3),dimso(4),
     +                             dimsi(1),dimsi(2),dimsi(3), vecleni)
            ELSEIF (datatype.EQ.2) THEN
              CALL real_compute(rt(tfield+1), ro(ofield+1), ri(ifield+1)
     $,
     +                          dimst(1),dimst(2),dimst(3),dimst(4),
     +                          dimso(1),dimso(2),dimso(3),dimso(4),
     +                          dimsi(1),dimsi(2),dimsi(3), vecleni)
            ELSEIF (datatype.EQ.3) THEN
              CALL double_compute(dt(tfield+1), do(ofield+1), di(ifield+
     $1),
     +                            dimst(1),dimst(2),dimst(3),dimst(4),
     +                            dimso(1),dimso(2),dimso(3),dimso(4),
     +                            dimsi(1),dimsi(2),dimsi(3), vecleni)
	    ENDIF

            CALL AVSfield_free(outdata)
	    outdata = tempdata

	    total = total + 1
	    call AVSmodify_parameter('total sets',
     +	                             IOR(avs_minval,IOR(avs_value,avs_max
     $val)),
     +                               total, total, total)

	  ELSE
	    call AVSmark_output_unchanged('outdata')
	  ENDIF

        ENDIF

      ELSE

	  call AVSmark_output_unchanged('outdata')

      ENDIF

C <---- END OF USER-SUPPLIED CODE SECTION #3
       inner_compute = 1
       return
       end

C **********************************************************************
       SUBROUTINE byte_compute(xt,xo,xi,
     +                         tres1, tres2, tres3, tres4,
     +                         ores1, ores2, ores3, ores4,
     +                         ires1, ires2, ires3, veclen)
       IMPLICIT NONE
       INTEGER veclen
       INTEGER tres1, tres2, tres3, tres4
       INTEGER ores1, ores2, ores3, ores4
       INTEGER ires1, ires2, ires3
       BYTE xt(veclen,tres1, tres2, tres3, tres4)
       BYTE xo(veclen,ores1, ores2, ores3, ores4)
       BYTE xi(veclen,ires1, ires2, ires3)

       INTEGER i,j,k,l,v
       INTEGER ii, jj, kk

       ii = tres1 - ires1
       jj = tres2 - ires2
       kk = tres3 - ires3

       DO l = 1, ores4
	 DO k = 1, ores3
	   DO j = 1, ores2
	     DO i = 1, ores1
	       DO v = 1, veclen
		 xt(v,i,j,k,l) = xo(v,i,j,k,l)
	       ENDDO
	     ENDDO
	   ENDDO
	 ENDDO
       ENDDO

       DO k = 1, ires3
	 DO j = 1, ires2
	   DO i = 1, ires1
	     DO v = 1, veclen
	       xt(v,i+ii,j+jj,k+kk,tres4) = xi(v,i,j,k)
	     ENDDO
	   ENDDO
	 ENDDO
       ENDDO

       RETURN
       END
C **********************************************************************
       SUBROUTINE integer_compute(xt,xo,xi,
     +                            tres1, tres2, tres3, tres4,
     +                            ores1, ores2, ores3, ores4,
     +                            ires1, ires2, ires3, veclen)
       IMPLICIT NONE
       INTEGER veclen
       INTEGER tres1, tres2, tres3, tres4
       INTEGER ores1, ores2, ores3, ores4
       INTEGER ires1, ires2, ires3
       INTEGER xt(veclen,tres1, tres2, tres3, tres4)
       INTEGER xo(veclen,ores1, ores2, ores3, ores4)
       INTEGER xi(veclen,ires1, ires2, ires3)

       INTEGER i,j,k,l,v
       INTEGER ii, jj, kk

       ii = tres1 - ires1
       jj = tres2 - ires2
       kk = tres3 - ires3

       DO l = 1, ores4
	 DO k = 1, ores3
	   DO j = 1, ores2
	     DO i = 1, ores1
	       DO v = 1, veclen
		 xt(v,i,j,k,l) = xo(v,i,j,k,l)
	       ENDDO
	     ENDDO
	   ENDDO
	 ENDDO
       ENDDO

       DO k = 1, ires3
	 DO j = 1, ires2
	   DO i = 1, ires1
	     DO v = 1, veclen
	       xt(v,i+ii,j+jj,k+kk,tres4) = xi(v,i,j,k)
	     ENDDO
	   ENDDO
	 ENDDO
       ENDDO

       RETURN
       END
C **********************************************************************
       SUBROUTINE real_compute(xt,xo,xi,
     +                         tres1, tres2, tres3, tres4,
     +                         ores1, ores2, ores3, ores4,
     +                         ires1, ires2, ires3, veclen)
       IMPLICIT NONE
       INTEGER veclen
       INTEGER tres1, tres2, tres3, tres4
       INTEGER ores1, ores2, ores3, ores4
       INTEGER ires1, ires2, ires3
       REAL*4  xt(veclen,tres1, tres2, tres3, tres4)
       REAL*4  xo(veclen,ores1, ores2, ores3, ores4)
       REAL*4  xi(veclen,ires1, ires2, ires3)

       INTEGER i,j,k,l,v
       INTEGER ii, jj, kk

       ii = tres1 - ires1
       jj = tres2 - ires2
       kk = tres3 - ires3

       DO l = 1, ores4
	 DO k = 1, ores3
	   DO j = 1, ores2
	     DO i = 1, ores1
	       DO v = 1, veclen
		 xt(v,i,j,k,l) = xo(v,i,j,k,l)
	       ENDDO
	     ENDDO
	   ENDDO
	 ENDDO
       ENDDO

       DO k = 1, ires3
	 DO j = 1, ires2
	   DO i = 1, ires1
	     DO v = 1, veclen
	       xt(v,i+ii,j+jj,k+kk,tres4) = xi(v,i,j,k)
	     ENDDO
	   ENDDO
	 ENDDO
       ENDDO

       RETURN
       END
C **********************************************************************
       SUBROUTINE double_compute(xt,xo,xi,
     +                           tres1, tres2, tres3, tres4,
     +                           ores1, ores2, ores3, ores4,
     +                           ires1, ires2, ires3, veclen)
       IMPLICIT NONE
       INTEGER veclen
       INTEGER tres1, tres2, tres3, tres4
       INTEGER ores1, ores2, ores3, ores4
       INTEGER ires1, ires2, ires3
       REAL*8  xt(veclen,tres1, tres2, tres3, tres4)
       REAL*8  xo(veclen,ores1, ores2, ores3, ores4)
       REAL*8  xi(veclen,ires1, ires2, ires3)

       INTEGER i,j,k,l,v
       INTEGER ii, jj, kk

       ii = tres1 - ires1
       jj = tres2 - ires2
       kk = tres3 - ires3

       DO l = 1, ores4
	 DO k = 1, ores3
	   DO j = 1, ores2
	     DO i = 1, ores1
	       DO v = 1, veclen
		 xt(v,i,j,k,l) = xo(v,i,j,k,l)
	       ENDDO
	     ENDDO
	   ENDDO
	 ENDDO
       ENDDO

       DO k = 1, ires3
	 DO j = 1, ires2
	   DO i = 1, ires1
	     DO v = 1, veclen
	       xt(v,i+ii,j+jj,k+kk,tres4) = xi(v,i,j,k)
	     ENDDO
	   ENDDO
	 ENDDO
       ENDDO

       RETURN
       END
C **********************************************************************
C Initialization for modules contained in this file.
C **********************************************************************
       subroutine AVSinit_modules
C   IAC CODE CHANGE :        include 'avs/avs.inc'
	INCLUDE '/usr/avs/include/avs.inc'

       external inner_spec
       integer inner_spec
       call AVSmodule_from_desc(inner_spec)
       end

 
C ----> START OF USER-SUPPLIED CODE SECTION #4 (SUBROUTINES, FUNCTIONS, UTILITY ROUTINES)
C <---- END OF USER-SUPPLIED CODE SECTION #4