!######################################################################
      SUBROUTINE imb_hemisphere(numIB)
!######################################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      DOUBLE PRECISION:: thc,PI,thz(80),zccos,zcsin
      INTEGER      :: M,L,K,c,nxhem,nyhem,p,Lt,Lrow1,Lrow2
      INTEGER      :: strlen2,nzr(80),izr,maxnzr
      CHARACTER*8  :: char_block2
      CHARACTER*31 :: gridfile
      DOUBLE PRECISION,allocatable,dimension (:) :: ztemp_layer
      DOUBLE PRECISION,allocatable,dimension (:,:) :: Rtemp_layer
      INTEGER,allocatable,dimension (:) :: ctot_layer,nodes_layer
      INTEGER,allocatable,dimension (:,:) :: nodes_percyl_layer

      PI = 4.D0*DATAN(1.D0)

         write(char_block2,'(I8)') myrank
         strlen2=LEN(TRIM(ADJUSTL(char_block2)))
         char_block2=REPEAT('0',(3-strlen2))//TRIM(ADJUSTL(char_block2))
         gridfile='geom_HemiSphere_'//TRIM(ADJUSTL(char_block2))//'.dat'
         open (unit=2, file=gridfile)

	maxnzr=0 ;   maxnode = 0 ; M=numIB

	nzr(M) = nint((2.d0*PI*R(M)/2.d0)/dxm) !Number of planes
	thz(M) = PI/(nzr(M))
	maxnzr=max(maxnzr,nzr(M))
      write (2,*) 'variables=x,y,z'

	allocate (ztemp_layer(maxnzr),ctot_layer(maxnzr))
      allocate (nodes_layer(10000),Rtemp_layer(maxnzr,100))
	allocate (nodes_percyl_layer(maxnzr,100))

         nodes_percyl_layer = 0 ;    nodes_layer = 0 ;nodes_layer=0

	  M=numIB
	     nodes(M) = 0

	 do izr = nzr(M)/2+1,nzr(M)	 	  !*****
	      c =1
         if (izr.eq.1) then
	   Rtemp_layer(izr,c) = 0.d0
         else
	   Rtemp_layer(izr,c) = R(M)*cos(thz(M)*(izr-1)-(PI/2.d0))
	   ztemp_layer(izr) = R(M)*sin(thz(M)*(izr-1)-(PI/2.d0))
     &		+dzm*0.49999d0
         end if
	      do while (Rtemp_layer(izr,c).ge.0.)		!gt!!!
                nodes_layer(izr) = nodes_layer(izr) +
     &  NINT(2.0*PI*Rtemp_layer(izr,c)/dxm)
                nodes_percyl_layer(izr,c) =
     &  NINT(2.0*PI*Rtemp_layer(izr,c)/dxm)
               if (Rtemp_layer(izr,c).eq.0.) then
                nodes_layer(izr) = nodes_layer(izr) + 1
                nodes_percyl_layer(izr,c) = 1
               end if
               c = c + 1
               Rtemp_layer(izr,c) = Rtemp_layer(izr,c-1)- dxm
             if(c.ge.cmax(M)) goto 555
	      end do

555	CONTINUE
              ctot_layer(izr) = 1 !c - 1
	      if(ctot_layer(izr) .gt. 100) then
	      print*, 'allocate problem in Rtemp_layer'
	      end if
          end do

	M=numIB ; Cz(M)=0.d0
!!!!!!!!!!!!!!!!!!! Bed of hemispheres --> uncomment the following :
	Cx(M)=0.08d0	; nxhem=20
	Cy(M)=0.09d0	; nyhem=7

	 izr=nzr(M)/2+1   !*****
	    K = 1
	 do while(izr.le.nzr(M))
	   do c = 1,ctot_layer(izr)
	    thc = 2.d0*PI/nodes_percyl_layer(izr,c)
	     do L = 1,nodes_percyl_layer(izr,c)
	      zccos = cos(2.d0*PI*(L-1)/nodes_percyl_layer(izr,c)+thc)
	      zcsin = sin(2.d0*PI*(L-1)/nodes_percyl_layer(izr,c)+thc)
            nodex(M,K) = Cx(M) + Rtemp_layer(izr,c)*zccos
	      nodey(M,K) = Cy(M) + Rtemp_layer(izr,c)*zcsin
	      nodez(M,K) = dzm*0.499d0 + R(M)*sin(thz(M)*(izr-1)-(PI/2.d0))
	      write(2,89) nodex(M,K), nodey(M,K), nodez(M,K)
               K = K + 1
	     end do
	    end do
            izr = izr + 1
       end do

	 K=K-1
 	      nodes(M) = K-1
  	      maxnode = max(maxnode,nodes(M))

	  L=0 ;	 Lt=K	!points of a hemisphere

! First row
	     do p=2,nxhem
		Do L=1,K
		 Lt=Lt+1
		 nodex(M,Lt)=nodex(M,L)+0.16d0*(p-1)
		 nodey(M,Lt)=nodey(M,L)
		 nodez(M,Lt)=nodez(M,L)
	      write(2,89) nodex(M,Lt), nodey(M,Lt), nodez(M,Lt)
		Enddo
	     enddo
	     Lrow1=Lt

! Second row
	     do p=1,nxhem-1
		Do L=1,K
		 Lt=Lt+1
		 nodex(M,Lt)=nodex(M,L)+0.16d0*(p-1)+0.08d0
		 nodey(M,Lt)=nodey(M,L)+0.16d0+0.005d0
		 nodez(M,Lt)=nodez(M,L)
	      write(2,89) nodex(M,Lt), nodey(M,Lt), nodez(M,Lt)
		Enddo
	     enddo
	     Lrow2=Lt

! 3rd row
	     do K=1,Lrow1
		 Lt=Lt+1
		 nodex(M,Lt)=nodex(M,K)
		 nodey(M,Lt)=nodey(M,K)+0.16d0*2.d0+0.005d0
		 nodez(M,Lt)=nodez(M,K)
	      write(2,89) nodex(M,Lt), nodey(M,Lt), nodez(M,Lt)
	     enddo
! 5th row
	     do K=1,Lrow1
		 Lt=Lt+1
		 nodex(M,Lt)=nodex(M,K)
		 nodey(M,Lt)=nodey(M,K)+0.16d0*4.d0+0.005d0
		 nodez(M,Lt)=nodez(M,K)
	      write(2,89) nodex(M,Lt), nodey(M,Lt), nodez(M,Lt)
	     enddo
! 7th row
	     do K=1,Lrow1
		 Lt=Lt+1
		 nodex(M,Lt)=nodex(M,K)
		 nodey(M,Lt)=nodey(M,K)+0.005d0+0.16d0*6.d0
		 nodez(M,Lt)=nodez(M,K)
	      write(2,89) nodex(M,Lt), nodey(M,Lt), nodez(M,Lt)
	     enddo

! 4th row
	     do K=Lrow1+1,Lrow2
		 Lt=Lt+1
		 nodex(M,Lt)=nodex(M,K)
		 nodey(M,Lt)=nodey(M,K)+0.16d0*2.d0
		 nodez(M,Lt)=nodez(M,K)
	      write(2,89) nodex(M,Lt), nodey(M,Lt), nodez(M,Lt)
	     enddo
! 6th row
	     do K=Lrow1+1,Lrow2
		 Lt=Lt+1
		 nodex(M,Lt)=nodex(M,K)
		 nodey(M,Lt)=nodey(M,K)+0.16d0*4.d0
		 nodez(M,Lt)=nodez(M,K)
	      write(2,89) nodex(M,Lt), nodey(M,Lt), nodez(M,Lt)
	     enddo

 	      nodes(M) = Lt !K-1
  	      maxnode = max(maxnode,nodes(M))

	deallocate (ztemp_layer,ctot_layer,nodes_layer)
	deallocate (nodes_percyl_layer,Rtemp_layer)

      close (2)

	  write(6,*) 'Number of layers : ',maxnzr
        write(6,87) '** Hemisphere',numIB,', # of nodes : ',nodes(numIB)

   87 FORMAT (a,i2,a,i6)
   88 FORMAT (i15)
   89 FORMAT (3e20.5)

      RETURN
      end
!######################################################################
      SUBROUTINE imb_dune(numIB)
!######################################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      DOUBLE PRECISION:: thc,PI,xtemp,ytemp
      INTEGER      :: P,M,L,I,K,c,nxlay,nylay,maxc,strlen2
      CHARACTER*8  :: char_block2
      CHARACTER*31 :: gridfile

         PI = 4.D0*DATAN(1.D0)

         write(char_block2,'(I3)') numIB
         strlen2=LEN(TRIM(ADJUSTL(char_block2)))
         char_block2=REPEAT('0',(3-strlen2))//TRIM(ADJUSTL(char_block2))
         gridfile='geom_Dune_'//TRIM(ADJUSTL(char_block2))//'.dat'
         open (unit=2, file=gridfile)
         write (2,*) 'variables="x","y","z"'

	 maxnode = 0   ;  M=numIB   ; nodes(M) = 0 ; L = 1
	 nylay=((yen-yst)/dym)  ;  nxlay=((xen-xst)/dxm)

	write(6,*)'Dune, long:',nxlay,'trans:',nylay

	 Do P=1,nylay
        Do 	K=1,nxlay
	 xtemp=dxm*0.4999999d0+(K-1)*dxm ; ytemp=dym*0.4999999d0+(P-1)*dym

	 if (xtemp.le.0.08d0) then	!1 section
	      maxc=INT(0.16d0/dzm)+1
		do c=1,maxc
	       nodex(M,L)=xtemp
	 	 nodey(M,L)=ytemp
	 	 nodez(M,L)=dzm*0.4999999d0+(c-1)*dzm
         	 write(2,89) nodex(M,L),nodey(M,L),nodez(M,L)
		 L=L+1
		enddo
	 endif

	 if (xtemp.gt.0.08d0 .and. xtemp.le.0.40d0) then	!2 section
	      maxc=INT((0.20d0-(xtemp)*0.5d0)/dzm)+1
		do c=1,maxc
	       nodex(M,L)=xtemp
	 	 nodey(M,L)=ytemp
	 	 nodez(M,L)=(0.20d0-xtemp*0.5d0)-(c-1)*dzm
!	 	 nodez(M,L)=dzm*0.4999999d0+(c-1)*dzm
         	 write(2,89) nodex(M,L),nodey(M,L),nodez(M,L)
		 L=L+1
		enddo
	 endif

	 if (xtemp.gt.0.60d0 .and. xtemp.le.1.10d0) then !3 section
	      maxc=INT((xtemp*0.036d0-0.0216d0)/dzm)+1
		do c=1,maxc
	       nodex(M,L)=xtemp
	 	 nodey(M,L)=ytemp
	 	 nodez(M,L)=(xtemp*0.036d0-0.0216d0)-(c-1)*dzm
!	 	 nodez(M,L)=dzm*0.4999999d0+(c-1)*dzm
         	 write(2,89) nodex(M,L),nodey(M,L),nodez(M,L)
		 L=L+1
		enddo
	 endif

	 if (xtemp.gt.1.10d0 .and. xtemp.le.2.6d0) then	!4 section
	      maxc=INT((xtemp*0.088d0-0.0788d0)/dzm)+1
		do c=1,maxc
	       nodex(M,L)=xtemp
	 	 nodey(M,L)=ytemp
	 	 nodez(M,L)=(xtemp*0.088d0-0.0788d0)-(c-1)*dzm
!	 	 nodez(M,L)=dzm*0.4999999d0+(c-1)*dzm
         	 write(2,89) nodex(M,L),nodey(M,L),nodez(M,L)
		 L=L+1
		enddo
	 endif
	 if (xtemp.gt.2.60d0 .and. xtemp.le.3.12d0) then !5 section
	      maxc=INT((xtemp*0.01923d0+0.10d0)/dzm)+1
		do c=1,maxc
	       nodex(M,L)=xtemp
	 	 nodey(M,L)=ytemp
 	 	 nodez(M,L)=(xtemp*0.01923d0+0.10d0)-(c-1)*dzm
!	 	 nodez(M,L)=dzm*0.4999999d0+(c-1)*dzm
         	 write(2,89) nodex(M,L),nodey(M,L),nodez(M,L)
		 L=L+1
		enddo
	 endif
	 if (xtemp.gt.3.12d0) then	!6 section
	      maxc=INT((0.16d0-0.d0)/dzm)+1
		do c=1,maxc
	       nodex(M,L)=xtemp
	 	 nodey(M,L)=ytemp
	 	 nodez(M,L)=dzm*0.4999999d0+(c-1)*dzm
         	 write(2,89) nodex(M,L),nodey(M,L),nodez(M,L)
		 L=L+1
		enddo
	 endif
 	 Enddo
	Enddo
879	CONTINUE

           nodes(M) = L-1
           maxnode = max(maxnode,nodes(M))
      close (2)

	  write(6,*) 'Number of layers : ',nylay
        write(6,87) '** Dune',numIB,', # of nodes  :  ',nodes(numIB)

   87 FORMAT (a,i2,a,i6)
   89 FORMAT (3e20.5)
      RETURN
      end
!######################################################################
      SUBROUTINE imb_cone(numIB)
!######################################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      DOUBLE PRECISION:: thc,PI,Rtemp
      INTEGER      ::M,L,I,K,c,nlay,maxc,strlen2,nodes_percyl
      CHARACTER*8  :: char_block2
      CHARACTER*31 :: gridfile

         PI = 4.D0*DATAN(1.D0)

         write(char_block2,'(I3)') numIB
         strlen2=LEN(TRIM(ADJUSTL(char_block2)))
         char_block2=REPEAT('0',(3-strlen2))//TRIM(ADJUSTL(char_block2))
         gridfile='geom_Cone_'//TRIM(ADJUSTL(char_block2))//'.dat'
         open (unit=2, file=gridfile)
         write (2,*) 'variables="x","y","z"'

	 maxnode = 0   ;  M=numIB
	 Rtemp = R(M); nodes(M) = 0 ; L = 1
	 nlay=((zend(M)-zini(M))/dzm)

        Do 	K=1,nlay
		Rtemp=(R(M)-R(M)/(zend(M)-zini(M))*K*dzm)/2.d0
		if(K*dzm.gt.zen) goto 879
         	maxc=INT(Rtemp/dxm)

		Do c=1,maxc
            nodes_percyl = NINT(2.d0*PI*Rtemp/dxm)
            thc = 2.d0*PI/nodes_percyl

		 Do I=1,nodes_percyl
	 nodex(M,L)=Cx(M)+Rtemp*cos(2.d0*PI*(I-1)/nodes_percyl+thc+K/3)
       nodey(M,L)=Cy(M)+Rtemp*sin(2.d0*PI*(I-1)/nodes_percyl+thc+K/3)
       nodez(M,L)=zini(M)+dzm*(K-1)+0.49999d0*dzm
          write(2,89) nodex(M,L),nodey(M,L),nodez(M,L)
          L = L + 1
		 Enddo

		Rtemp = Rtemp - dxm
		Enddo
	  Enddo

879	CONTINUE

           nodes(M) = L-1
           maxnode = max(maxnode,nodes(M))
      close (2)

	  write(6,*) 'Number of layers : ',nlay
        write(6,87) '** CONE',numIB,', # of nodes  :  ',nodes(numIB)

   87 FORMAT (a,i2,a,i8)
   89 FORMAT (3e20.5)
      RETURN
      end
!#############################################################
      SUBROUTINE imb_square(numIB)
!#############################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      DOUBLE PRECISION:: nodexmin,nodexmax,nodeymin,nodeymax
      INTEGER      :: M,L,nin,njn,I,J,k,strlen2,c,nlay,maxc,clay
      CHARACTER*8  :: char_block2
      CHARACTER*31 :: gridfile

         write(char_block2,'(I8)') myrank
         strlen2=LEN(TRIM(ADJUSTL(char_block2)))
         char_block2=REPEAT('0',(3-strlen2))//TRIM(ADJUSTL(char_block2))
         gridfile='geom_Squ_'//TRIM(ADJUSTL(char_block2))//'.dat'
         open (unit=2, file=gridfile)
         write (2,*) 'variables=x,y,z'

	  M=numIB   ;  maxnode = 0 ; L=0

         if (linfin(numIB).eq.1) then
           zini(M)=0.d0 ;   nlay=((zen-zst)/dzm)
         else if (linfin(numIB).eq.0) then
	   nlay=((zend(M)-zini(M))/dzm)
         endif

         maxc=INT(R(M)/dxm)+1

         if(cmax(M).gt.maxc) cmax(M)=maxc

	DO K=1,nlay
	 if(linfin(M).eq.0) then   !This adds the lids of the finite
	  if (K.le.cmax(M) .or. K.ge.(nlay-cmax(M)+1)) then
	   clay=maxc
	  else
	   clay=cmax(M)
	  endif
	 else
	   clay=cmax(M)
	 endif

	if(axis(numIB).eq.2) then
	 Do c=1,clay
 	   nodexmin = Cx(M)+(c-1)*dxm
 	   nodexmax = Cx(M)+2.0*(R(M)-(c-1)*dxm)
         nodeymin = Cz(M)+(c-1)*dzm
         nodeymax = Cz(M)+2.0*(R(M)-(c-1)*dzm)

         nin=2*((R(M)-dxm*(c-1))/dxm)+1 !elements in x-direction
         njn=2*((R(M)-dzm*(c-1))/dzm)+1 !elements in y-direction

          do I=1,nin				!Bottom horizontal edge
            L=L+1
            nodex(M,L)=nodexmin+dxm*(I-1)
            nodey(M,L)=zini(M) +dym*(K-1)
            nodez(M,L)=nodeymin
          enddo
          do J=2,njn				!Right vertical edge
            L=L+1
            nodex(M,L)=nodexmax
            nodey(M,L)=zini(M) +dym*(K-1)
            nodez(M,L)=nodeymin+dzm*(J-1)
          enddo
           do I=2,nin
            L=L+1
            nodex(M,L)=nodexmax-dxm*(I-1)
            nodey(M,L)=zini(M) +dym*(K-1)
            nodez(M,L)=nodeymax
           enddo
           do J=2,njn-1
            L=L+1
            nodex(M,L)=nodexmin
            nodey(M,L)=zini(M) +dym*(K-1)
            nodez(M,L)=nodeymax-dzm*(J-1)
           enddo
	 Enddo

	ELSE
	 Do c=1,clay
 	   nodexmin = Cx(M)-R(M)+(c-1)*dxm
 	   nodexmax = Cx(M)+R(M)-(c-1)*dxm
         nodeymin = Cy(M)-R(M)+(c-1)*dym
         nodeymax = Cy(M)+R(M)-(c-1)*dym

         nin=2*((R(M)-dxm*(c-1))/dxm)+1
         njn=2*((R(M)-dym*(c-1))/dym)+1

          do I=1,nin
            L=L+1
            nodex(M,L)=nodexmin+dxm*(I-1)
            nodey(M,L)=nodeymin
            nodez(M,L)=zini(M)+dzm*(K-1)
          enddo
          do J=2,njn
            L=L+1
            nodex(M,L)=nodexmax
            nodey(M,L)=nodeymin+dym*(J-1)
            nodez(M,L)=zini(M)+dzm*(K-1)
          enddo
           do I=2,nin
            L=L+1
            nodex(M,L)=nodexmax-dxm*(I-1)
            nodey(M,L)=nodeymax
            nodez(M,L)=zini(M)+dzm*(K-1)
           enddo
           do J=2,njn-1
            L=L+1
            nodex(M,L)=nodexmin
            nodey(M,L)=nodeymax-dym*(J-1)
            nodez(M,L)=zini(M)+dzm*(K-1)
           enddo
       Enddo !c

	ENDIF!axis

         ENDDO

         nodes(M)=L
         maxnode = max(maxnode,nodes(M))

         Do L = 1,nodes(M)
            write (2,89) nodex(M,L),nodey(M,L),nodez(M,L)
         End do

      close (2)

   89 FORMAT (3e20.5)

      RETURN
      end
!######################################################################
      SUBROUTINE imb_cylinder(numIB)
!######################################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      DOUBLE PRECISION:: thc,PI,Rtemp(1000),zccos,zcsin
      INTEGER      ::M,L,I,K,c,ctot,nlay,maxc,strlen2,nodes_percyl(1000)
      CHARACTER*8  :: char_block2
      CHARACTER*31 :: gridfile

         PI = 4.D0*DATAN(1.D0)

         write(char_block2,'(I8)') numIB
         strlen2=LEN(TRIM(ADJUSTL(char_block2)))
         char_block2=REPEAT('0',(3-strlen2))//TRIM(ADJUSTL(char_block2))
         gridfile='geom_Cyl_'//TRIM(ADJUSTL(char_block2))//'.dat'
         open (unit=2, file=gridfile)
         write (2,*) 'variables=x,y,z'

	 maxnode = 0; nodes_percyl = 0  ; M=numIB
	 Rtemp = R(M); nodes(M) = 0; c =1

         maxc=INT(R(M)/dxm)+1
         if(cmax(M).gt.maxc) cmax(M)=maxc

            Do while (Rtemp(c).ge.0.d0 .and. c.le.maxc)
               IF (c.eq.1) then
                nodes(M) = nodes(M) + NINT(2.d0*PI*Rtemp(c)/dxm)
                nodes_percyl(c) =     NINT(2.d0*PI*Rtemp(c)/dxm)
               else
                nodes(M) = nodes(M) + NINT(2.d0*PI*Rtemp(c)/(dxm))
                nodes_percyl(c)=NINT(2.0*PI*Rtemp(c)/(dxm))
               end if
              IF (Rtemp(c).eq.0.d0) nodes(M)        = nodes(M) + 1
              IF (Rtemp(c).eq.0.d0) nodes_percyl(c) = 1
              c = c + 1
              Rtemp(c) = Rtemp(c-1) - dxm
           End do

           ctot = c - 1

           if (linfin(M).eq.1) then
             zini(M)=zst
		if(axis(M).eq.1) nlay=((xen-xst)/dxm)-1
		if(axis(M).eq.2) nlay=((yen-yst)/dym)-1
		if(axis(M).eq.3) nlay=((zen-zst)/dzm)-1
           endif
           if (linfin(M).eq.0) then
		if(axis(M).eq.1) nlay=((zend(M)-zini(M))/dxm)+1
		if(axis(M).eq.2) nlay=((zend(M)-zini(M))/dym)+1
		if(axis(M).eq.3) nlay=((zend(M)-zini(M))/dzm)+1
           endif

	  L=1
	  Do K=1,nlay
		 if(linfin(M).eq.0) then   !This adds the lids of the finite
		  if (K.le.cmax(M) .or. K.ge.(nlay-cmax(M)+1)) then
		   ctot=maxc
		  else
		   ctot=cmax(M)
		  endif
		 else
		   ctot=cmax(M)
		endif
           Do c = 1,ctot
            thc = 2.d0*PI/nodes_percyl(c)
             Do I = 1,nodes_percyl(c)
	        zccos= cos(2.d0*PI*(I-1)/nodes_percyl(c)+thc)
	        zcsin= sin(2.d0*PI*(I-1)/nodes_percyl(c)+thc)
			if(axis(numIB).eq.1) then
			  nodez(M,L)= Cz(M) + Rtemp(c)*zccos
		        nodey(M,L)= Cy(M) + Rtemp(c)*zcsin
		        nodex(M,L)= zini(M)+dxm*(K-1)+dxm*0.499999d0
			elseif(axis(numIB).eq.2) then
			  nodex(M,L)= Cx(M) + Rtemp(c)*zccos
		        nodey(M,L)= zini(M)+dym*(K-1)+dym*0.499999d0
		        nodez(M,L)= Cz(M) + Rtemp(c)*zcsin
			elseif(axis(numIB).eq.3) then
			  nodex(M,L)= Cx(M) + Rtemp(c)*zccos
		        nodey(M,L)= Cy(M) + Rtemp(c)*zcsin
		        nodez(M,L)= zini(M)+dzm*(K-1)+dzm*0.499999d0
			endif
              write(2,89) nodex(M,L),nodey(M,L),nodez(M,L)
              L = L + 1
             End do
            End do
          End Do

           nodes(M) = L-1
           maxnode = max(maxnode,nodes(M))

      close (2)

        write(6,*) ' '
        write(6,87) '** CYLINDER',numIB,', # of nodes  :  ',nodes(numIB)

   87 FORMAT (a,i2,a,i5)
   89 FORMAT (3e20.5)

      RETURN
      end
!#############################################################
      SUBROUTINE imb_cube(numIB)
!#############################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      DOUBLE PRECISION:: nodexmin,nodexmax,nodeymin,nodeymax
      DOUBLE PRECISION:: nodezmin,nodezmax
      INTEGER      :: M,L,nin,njn,nkn,I,J,k,strlen2
      CHARACTER*8  :: char_block2
      CHARACTER*31 :: gridfile

         write(char_block2,'(I8)') myrank
         strlen2=LEN(TRIM(ADJUSTL(char_block2)))
         char_block2=REPEAT('0',(3-strlen2))//TRIM(ADJUSTL(char_block2))
         gridfile='geom_Cube_'//TRIM(ADJUSTL(char_block2))//'.dat'
         open (unit=2, file=gridfile)
         write (2,*) 'variables="x","y","z"'

         maxnode = 0
! -------------------------------------------------
	 M=numIB

         nodexmin=Cx(M)-R(M); nodexmax=Cx(M)+R(M)
         nodeymin=Cy(M)-R(M); nodeymax=Cy(M)+R(M)
         nodezmin=Cz(M)-R(M); nodezmax=Cz(M)+R(M)

         nin =2.d0*R(M)/dxm
         if(abs(nin-2.0*R(M)/dxm).ge.0.999999999)
     & then
            nin=nin+1
            print*,'absurd-x!!!!!'
         end if
         nin=nin+1

         njn =2.d0*R(M)/dym
         if(abs(njn-2.0*R(M)/dym).ge.0.999999999)
     & then
            njn=njn+1
            print*,'absurd-y!!!!!'
         end if
         njn=njn+1

         nkn =2.d0*R(M)/dzm
         if(abs(nkn-2.0*R(M)/dzm).ge.0.999999999)
     & then
            nkn=nkn+1
            print*,'absurd-y!!!!!'
         end if
         nkn=nkn+1

         nodes(M)= nkn * nin * njn
         maxnode = max(maxnode,nodes(M))

        Do k = 1,nkn
         Do I = 1, nin
          Do J = 1, njn
             L = (k-1)*nin*njn + (I-1)*njn + J
              IF (I.eq.1) THEN
               nodex(M,L) = nodexmin
              else IF (I.eq.nin) THEN
               nodex(M,L) = nodexmax
              ELSE
               nodex(M,L) = nodex(M,L-njn) + dxm
              END IF
              IF (J.eq.1) THEN
               nodey(M,L) = nodeymin
              else IF (J.eq.njn) THEN
               nodey(M,L) = nodeymax
              ELSE
               nodey(M,L) = nodey(M,L-1) + dym
              END IF
              IF (K.eq.1) THEN
               nodez(M,L) = nodezmin
              else IF (K.eq.nkn) THEN
               nodez(M,L) = nodezmax
              ELSE
               nodez(M,L) = nodez(M,L-nin*njn) + dzm
              END IF
          End do
         End do
        end do
         Do L = 1,nodes(M)
            write (2,89) nodex(M,L),nodey(M,L),nodez(M,L)
         End do

      close (2)

   88 FORMAT (i5)
   89 FORMAT (3e20.5)

      RETURN
      end
!######################################################################
      SUBROUTINE imb_sphere(numIB)
!######################################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      DOUBLE PRECISION:: thc,PI,thz(80),zccos,zcsin
      INTEGER      :: M,L,K,c
      INTEGER      :: strlen2,nzr(80),izr,maxnzr
      CHARACTER*8  :: char_block2
      CHARACTER*31 :: gridfile
      DOUBLE PRECISION,allocatable,dimension (:,:) :: ztemp_layer
      DOUBLE PRECISION,allocatable,dimension (:,:,:) :: Rtemp_layer
      INTEGER,allocatable,dimension (:,:) :: ctot_layer,nodes_layer
      INTEGER,allocatable,dimension (:,:,:) :: nodes_percyl_layer

      PI = 4.D0*DATAN(1.D0)

         write(char_block2,'(I8)') myrank
         strlen2=LEN(TRIM(ADJUSTL(char_block2)))
         char_block2=REPEAT('0',(3-strlen2))//TRIM(ADJUSTL(char_block2))
         gridfile='geom_Sphere_'//TRIM(ADJUSTL(char_block2))//'.dat'
         open (unit=2, file=gridfile)

	maxnzr=0 ;   maxnode = 0
	M=numIB

	nzr(M) = nint((2.d0*PI*R(M)/2.d0)/dxm) !Number of planes
	thz(M) = PI/(nzr(M))
	maxnzr=max(maxnzr,nzr(M))
        write (2,*) 'variables="x","y","z"'

	allocate (ztemp_layer(1,maxnzr),ctot_layer(1,maxnzr))
        allocate (nodes_layer(1,10000),Rtemp_layer(1,maxnzr,100))
	allocate (nodes_percyl_layer(1,maxnzr,100))

         nodes_percyl_layer = 0 ;    nodes_layer = 0 ;nodes_layer=0

	  M=numIB
	     nodes(M) = 0

	 do izr = 1,nzr(M)
	      c =1
         if (izr.eq.1) then
	   Rtemp_layer(M,izr,c) = 0.d0
         else
	   Rtemp_layer(M,izr,c) = R(M)*cos(thz(M)*(izr-1)-(PI/2.d0))
	   ztemp_layer(M,izr) = R(M)*sin(thz(M)*(izr-1)-(PI/2.d0))+Cz(M)
         end if

	      do while (Rtemp_layer(M,izr,c).ge.0.)		!gt!!!
                nodes_layer(M,izr) = nodes_layer(M,izr) +
     &  NINT(2.0*PI*Rtemp_layer(M,izr,c)/dxm)
                nodes_percyl_layer(M,izr,c) =
     &  NINT(2.0*PI*Rtemp_layer(M,izr,c)/dxm)
               if (Rtemp_layer(M,izr,c).eq.0.) then
                nodes_layer(M,izr) = nodes_layer(M,izr) + 1
                nodes_percyl_layer(M,izr,c) = 1
               end if
               c = c + 1
               Rtemp_layer(M,izr,c) = Rtemp_layer(M,izr,c-1)- dxm

             if(c.ge.cmax(M)) goto 555

	      end do

555	CONTINUE
              ctot_layer(M,izr) = c - 1
	      if(ctot_layer(M,izr) .gt. 100) then
	      print*, 'allocate problem in Rtemp_layer'
	      end if
          end do

	M=numIB
	 izr=1
	    K = 1
	 do while(izr.le.nzr(M))
	   do c = 1,ctot_layer(M,izr)
	    thc = 2.d0*PI/nodes_percyl_layer(M,izr,c)
	     do L = 1,nodes_percyl_layer(M,izr,c)
	      zccos = cos(2.d0*PI*(L-1)/nodes_percyl_layer(M,izr,c)+thc)
	      zcsin = sin(2.d0*PI*(L-1)/nodes_percyl_layer(M,izr,c)+thc)
              nodex(M,K) = Cx(M) + Rtemp_layer(M,izr,c)*zccos
	      nodey(M,K) = Cy(M) + Rtemp_layer(M,izr,c)*zcsin
	      nodez(M,K) = Cz(M) + R(M)*sin(thz(M)*(izr-1)-(PI/2.d0))
	      write(2,89) nodex(M,K), nodey(M,K), nodez(M,K)
               K = K + 1
	     end do
	    end do
            izr = izr + 1
          end do
 	      nodes(M) = K-1
  	      maxnode = max(maxnode,nodes(M))

	deallocate (ztemp_layer,ctot_layer,nodes_layer)
	deallocate (nodes_percyl_layer,Rtemp_layer)

      close (2)

   88 FORMAT (i15)
   89 FORMAT (3e20.6)

      RETURN
      end
!#############################################################
      SUBROUTINE imb_file(numIB)
!#############################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      DOUBLE PRECISION:: PI,an
      INTEGER      :: L,nin,I,K,nlay,dummy,strlen
      CHARACTER*8  :: char_block2
      CHARACTER*31 :: gridfile
      DOUBLE PRECISION,ALLOCATABLE,DIMENSION (:) :: xfile,yfile,zfile

       PI = 4.D0*DATAN(1.D0)

         write(char_block2,'(I3)') numIB
         strlen=LEN(TRIM(ADJUSTL(char_block2)))
         char_block2=REPEAT('0',(3-strlen))//TRIM(ADJUSTL(char_block2))
         gridfile='geom_body_'//TRIM(ADJUSTL(char_block2))//'.dat'
         open (unit=2, file=gridfile)
!----      Load the file and proceed to interpolate     ----------
 	open(unit=1, file=filepoints(numIB))
	if (ibturbine(numIB)) then
           read(1,*)nin,nscatter(numIB)	!Mesh points
        else
           read(1,*)nin         !Mesh points
        end if

	select case(axis(numIB))			!Brunho2015
	CASE (1) !-------------------------------------------
		allocate(yfile(nin),zfile(nin))
		    DO L=1,nin
			 read(1,*)dummy,yfile(L),zfile(L)
		    ENDDO
		close (1)
		maxnode=0
		Cxor(numIB)=Cx(numIB)
		Cyor(numIB)=Cy(numIB)
		Czor(numIB)=Cz(numIB)
           if (linfin(numIB).eq.1) then
             zini(numIB)=xst ;   nlay=((xen-xst)/dxm)!-1
           else if (linfin(numIB).eq.0) then
	     nlay=((zend(numIB)-zini(numIB))/dxm)!-1
           endif
		nodes(numIB)=nin*nlay*imbnumber(numIB)
		maxnode = max(maxnode,nodes(numIB))
  		K=1
  		do L=1,nlay
   		 DO I=1,nin
	 	  nodex(numIB,K)=zini(numIB)+dxm*(L)+1.d-7
		  nodey(numIB,K)=yfile(I)+1.d-7
		  nodez(numIB,K)=zfile(I)+1.d-7
     		  K=K+1
   		 ENDDO
   		Enddo
	CASE (2) !-------------------------------------------
		allocate(xfile(nin),zfile(nin))
		    DO L=1,nin
			 read(1,*)xfile(L),zfile(L)
		    ENDDO
		close (1)
		maxnode=0
		Cxor(numIB)=Cx(numIB)
		Cyor(numIB)=Cy(numIB)
		Czor(numIB)=Cz(numIB)
           if (linfin(numIB).eq.1) then
             zini(numIB)=yst ;   nlay=((yen-yst)/dym)!-1
           else if (linfin(numIB).eq.0) then
	     nlay=((zend(numIB)-zini(numIB))/dym)!-1
           endif
		nodes(numIB)=nin*nlay*imbnumber(numIB)
		 	maxnode = max(maxnode,nodes(numIB))
  		K=1
  		do L=1,nlay
   		 DO I=1,nin
	 	  nodex(numIB,K)=xfile(I)+1.d-7
		  nodey(numIB,K)=zini(numIB)+dym*(L)+1.d-7
		  nodez(numIB,K)=zfile(I)+1.d-7
     		  K=K+1
   		 ENDDO
   		Enddo
	CASE (3) !-------------------------------------------
		allocate(xfile(nin),yfile(nin))
		    DO L=1,nin
			 read(1,*)xfile(L),yfile(L)
		    ENDDO
		close (1)
		maxnode=0
		Cxor(numIB)=Cx(numIB)
		Cyor(numIB)=Cy(numIB)
		Czor(numIB)=Cz(numIB)
           if (linfin(numIB).eq.1) then
             zini(numIB)=zst ;   nlay=((zen-zst)/dzm)!-1  !it was-1
           else if (linfin(numIB).eq.0) then
	     nlay=((zend(numIB)-zini(numIB))/dzm)+1
           endif
		nodes(numIB)=nin*nlay*imbnumber(numIB)
		maxnode = max(maxnode,nodes(numIB))
  		K=1
  		do L=1,nlay
   		 DO I=1,nin
	 	  nodex(numIB,K)=xfile(I)
		  nodey(numIB,K)=yfile(I)
	 	  nodez(numIB,K)=zini(numIB)+dzm*(L)-0.49*dzm
     		  K=K+1
   		 ENDDO
   		Enddo
	 write(6,*)'Number of layers : ',nlay
	  CASE (-1) !-------------------------------------------
		allocate(xfile(nin),yfile(nin),zfile(nin))
		  DO L=1,nin
		   read(1,*)xfile(L),yfile(L),zfile(L)
		  ENDDO
		close (1)
		maxnode=0   ; nlay=1
		Cxor(numIB)=Cx(numIB)
		Cyor(numIB)=Cy(numIB)
		Czor(numIB)=Cz(numIB)
		nodes(numIB)=nin*imbnumber(numIB)
		maxnode = max(maxnode,nodes(numIB))
   		DO I=1,nin
	 	  nodex(numIB,I)=xfile(I)+1.d-12
		  nodey(numIB,I)=yfile(I)+1.d-12
		  nodez(numIB,I)=zfile(I)+1.d-12
   		ENDDO
	end select
 !--------Local and global coordinates  --------------------------------
	IF (ibturbine(numIB)) then	!if body is a turbine
	   an=pitch(numIB)*PI/180.d0	   !Angle of attack in radians
	   do i=1,nin*nlay		   !Rotate the body.
	    nodex(numIB,i)=nodex(numIB,i)-xaero(numIB)
	    nodey(numIB,i)=nodey(numIB,i)-yaero(numIB)
	    nodez(numIB,i)=nodez(numIB,i)-zaero(numIB) !Gravity centre
!Rotated by the pitch angle
	 nodex(numIB,i)= nodex(numIB,i)*dcos(an)+nodey(numIB,i)*dsin(an)
	 nodey(numIB,i)=-nodex(numIB,i)*dsin(an)+nodey(numIB,i)*dcos(an)
!Set this as the local coordinates
	    nodexlocal(numIB,i)=nodex(numIB,i)
	    nodeylocal(numIB,i)=nodey(numIB,i)
	    nodezlocal(numIB,i)=nodez(numIB,i)
	   enddo
!From local to global coords applying the centre
	   do i=1,nin*nlay
	    nodex(numIB,i)=nodex(numIB,i)+Cxor(numIB)
	    nodey(numIB,i)=nodey(numIB,i)+Cyor(numIB)
	    nodez(numIB,i)=nodez(numIB,i)+Czor(numIB)
	   enddo
	 ELSE	!All bodies but turbine
	  do i=1,nin*nlay
	    nodexlocal(numIB,i)=nodex(numIB,i) !Set this as the local coordinates
	    nodeylocal(numIB,i)=nodey(numIB,i)
	    nodezlocal(numIB,i)=nodez(numIB,i)
	    nodex(numIB,i)=nodex(numIB,i)+Cxor(numIB)
	    nodey(numIB,i)=nodey(numIB,i)+Cyor(numIB)
	    nodez(numIB,i)=nodez(numIB,i)+Czor(numIB)
	   enddo
	ENDIF

	if(imb_shape(numIB).eq.5) call imb_number(numIB)
	if(imb_shape(numIB).ne.5) print*,'subroutine not finished'
       close(2)

   88 FORMAT (i5)
   89 FORMAT (3e25.5)
      RETURN
      end
!#############################################################
      SUBROUTINE imb_number(numIB)
!#############################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      integer, intent (in) :: numIB
      INTEGER      :: I,K

	K=nodes(numIB)/imbnumber(numIB) !# of Lagrangians per unit
      write(6,*)' '
      write(6,'(a,i3,a)')'**********   THE BODY ',numIB,' :'
	write(6,*)'Total # ofnodes              :',nodes(numIB)
	write(6,*)'# of bodies                  :',imbnumber(numIB)
	IF(imb_shape(numIB).eq.5 .and. axis(numIB).eq.-1)
     &		write(6,*)'No extrusion of the body !!!!'
!	IF(LSELFST(numIB))      write(6,*)'Turbine Self-Starting        :  YES'
!	IF(.not.LSELFST(numIB)) write(6,*)'Turbine Self-Starting        :  NO'
	write(2,*)'variables="x","y","z"'
!-----------------	1- body      --------------------------------
	if (imbnumber(numIB).eq.1) then
	  do i=1,K
	   nodex(numIB,i) = nodex(numIB,i)
	   nodey(numIB,i) = nodey(numIB,i)
	   nodez(numIB,i) = nodez(numIB,i)
	   write (2,89) nodex(numIB,i),nodey(numIB,i),nodez(numIB,i)
	  enddo
	endif
!-----------------	2- bodies      --------------------------------
      IF (imbnumber(numIB).eq.2) then
	 do i=1,K
	   nodex(numIB,i) = nodex(numIB,i)
	   nodey(numIB,i) = nodey(numIB,i) + R(numIB)
	   nodez(numIB,i) = nodez(numIB,i)
	  write (2,89) nodex(numIB,i),nodey(numIB,i),nodez(numIB,i)
	 enddo
	 do i=1,K
	  nodex(numIB,K+i)=-nodexlocal(numIB,i)
	  nodey(numIB,K+i)=-nodeylocal(numIB,i)
	  nodex(numIB,K+i)=nodex(numIB,K+i) + Cxor(numIB)
	  nodey(numIB,K+i)=nodey(numIB,K+i)+Cyor(numIB)-R(numIB)
	  nodez(numIB,K+i)=nodez(numIB,i)
         write (2,89) nodex(numIB,K+i),nodey(numIB,K+i),nodez(numIB,K+i)
	 enddo
      ENDIF
!-----------------	3- bodies      --------------------------------
	IF (imbnumber(numIB).eq.3) then
	do i=1,K
	  nodex(numIB,i) = nodex(numIB,i)
	  nodey(numIB,i) = nodey(numIB,i) + R(numIB)
	  nodez(numIB,i) = nodez(numIB,i)
	  write (2,89) nodex(numIB,i),nodey(numIB,i),nodez(numIB,i)
	enddo
        do i=1,K
	  nodex(numIB,K+i)=nodexlocal(numIB,i)*(-0.5)-
     &                  nodeylocal(numIB,i)*(DSQRT(3.)/2)
	  nodey(numIB,K+i)=nodexlocal(numIB,i)*(DSQRT(3.)/2)+
     &                  nodeylocal(numIB,i)*(-0.5)
	  nodex(numIB,K+i)=nodex(numIB,K+i)+Cxor(numIB)-
     &			  R(numIB)*DSQRT(3.)/2
	  nodey(numIB,K+i)=nodey(numIB,K+i)+Cyor(numIB)-R(numIB)*0.5
	  nodez(numIB,K+i)=nodez(numIB,i)
         write (2,89) nodex(numIB,K+i),nodey(numIB,K+i),nodez(numIB,K+i)
        enddo
        do i=1,K
	 nodex(numIB,2*K+i)=nodexlocal(numIB,i)*(-0.5)-
     &                     nodeylocal(numIB,i)*(-DSQRT(3.)/2)
	 nodey(numIB,2*K+i)=nodexlocal(numIB,i)*(-DSQRT(3.)/2)+
     &                     nodeylocal(numIB,i)*(-0.5)
	 nodex(numIB,2*K+i)=nodex(numIB,2*K+i)+Cxor(numIB)+
     &				R(numIB)*DSQRT(3.)/2
	 nodey(numIB,2*K+i)=nodey(numIB,2*K+i)+Cyor(numIB)-
     &				R(numIB)*0.5
	 nodez(numIB,2*K+i)=nodez(numIB,i)
         write (2,89) nodex(numIB,2*K+i),nodey(numIB,2*K+i)
     &   		,nodez(numIB,2*K+i)
        enddo
       ENDIF
!-----------------	4- bodies      --------------------------------
	IF (imbnumber(numIB).eq.4) then
       do i=1,K
	nodex(numIB,i) = nodex(numIB,i)
	nodey(numIB,i) = nodey(numIB,i) + R(numIB)
	nodez(numIB,i) = nodez(numIB,i)
	write (2,89) nodex(numIB,i),nodey(numIB,i),nodez(numIB,i)
       enddo
        do i=1,K
          nodex(numIB,K+i)=-nodeylocal(numIB,i)
          nodey(numIB,K+i)=nodexlocal(numIB,i)
          nodex(numIB,K+i)=nodex(numIB,K+i)+Cxor(numIB)-R(numIB)
          nodey(numIB,K+i)=nodey(numIB,K+i) + Cyor(numIB)
	  nodez(numIB,K+i)=nodez(numIB,i)
	 write (2,89) nodex(numIB,K+i),nodey(numIB,K+i),nodez(numIB,K+i)
       enddo
        do i=1,K
          nodex(numIB,2*K+i)=-nodexlocal(numIB,i)
          nodey(numIB,2*K+i)=-nodeylocal(numIB,i)
          nodex(numIB,2*K+i)=nodex(numIB,2*K+i) + Cxor(numIB)
          nodey(numIB,2*K+i)=nodey(numIB,2*K+i) + Cyor(numIB)-R(numIB)
	  nodez(numIB,2*K+i)=nodez(numIB,i)
         write (2,89) nodex(numIB,2*K+i),nodey(numIB,2*K+i)
     &   		,nodez(numIB,2*K+i)
       enddo
        do i=1,K
          nodex(numIB,3*K+i)=nodeylocal(numIB,i)
          nodey(numIB,3*K+i)=-nodexlocal(numIB,i)
          nodex(numIB,3*K+i)=nodex(numIB,3*K+i) + Cxor(numIB)+R(numIB)
          nodey(numIB,3*K+i)=nodey(numIB,3*K+i) + Cyor(numIB)
         write (2,89) nodex(numIB,3*K+i),nodey(numIB,3*K+i)
     &   		,nodez(numIB,3*K+i)
       enddo
	ENDIF

   88 FORMAT (i5)
   89 FORMAT (3e25.5)

	RETURN
	END SUBROUTINE
!#############################################################
      SUBROUTINE imb_moved(numIB)
!#############################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      INTEGER, intent(in) :: numIB
      DOUBLE PRECISION:: PI
      INTEGER      :: L,I,K,strlen,strlen2,Geom_Time1,nplot
      CHARACTER*8  :: char_block,num_ib
      CHARACTER*31 :: gridfile1
       PI = 4.D0*DATAN(1.D0)

      IF (myrank.ne.master) RETURN

       Geom_Time1=301

	nplot=1

	if(nplot.eq.2) then
         if (mod(itime,n_out).eq.0) then !Write in file when outputs are writen
           write(char_block,'(I6)') itime
           strlen=LEN(TRIM(ADJUSTL(char_block)))
           char_block=REPEAT('0',(6-strlen))//TRIM(ADJUSTL(char_block))
           write(num_ib,'(I2)') numIB
           strlen2=LEN(TRIM(ADJUSTL(num_ib)))
           num_ib=REPEAT('0',(2-strlen2))//TRIM(ADJUSTL(num_ib))
           gridfile1='Blade_'//TRIM(ADJUSTL(num_ib))//
     &      '_Time_'//TRIM(ADJUSTL(char_block))//'.plt'
           open (unit=Geom_Time1, file=gridfile1)
	   write(Geom_Time1,*)'title = points'
	   write(Geom_Time1,*)'variables=x,y,z'
	   write(Geom_Time1,*)
     &    'zone   ','i=  ',nodes(numIB),'DATAPACKING = POINT'
	 endif
 	endif

!- Distinguish between turbines (HA and VA) and non-turbines --------------
	IF (ibturbine(numIB)) then		! Turbine
!-------------------------------------------------------------------
	IF (turax(numIB).eq.1) then	! Vertical Axis
       do L=1,nodes(numIB)
      nodexlocal(numIB,L)=-R0(numIB,L)*dsin(rads(numIB)+alpha0(numIB,L))
      nodeylocal(numIB,L)= R0(numIB,L)*dcos(rads(numIB)+alpha0(numIB,L))
       enddo

	  do L=1,nodes(numIB)
		nodex(numIB,L) = nodexlocal(numIB,L) + Cxor(numIB)
		nodey(numIB,L) = nodeylocal(numIB,L) + Cyor(numIB)
   	    if (mod(itime,n_out).eq.0) then
	if(nplot.eq.2) write(Geom_Time1,89)
     &		nodex(numIB,L),nodey(numIB,L),nodez(numIB,L)
    	    endif
	  enddo

	ENDIF !Vertical axis
!-------------------------------------------------------------------
	IF (turax(numIB).eq.2 .OR. turax(numIB).eq.3) then	! Horizontal Axis  ! AND Actuator line -Pablo 09/17
       do L=1,nodes(numIB)
       nodeylocal(numIB,L)=R0(numIB,L)*dsin(rads(numIB)+alpha0(numIB,L))
       nodezlocal(numIB,L)=R0(numIB,L)*dcos(rads(numIB)+alpha0(numIB,L))
       enddo
	  do L=1,nodes(numIB)
		nodey(numIB,L) = nodeylocal(numIB,L) + Cyor(numIB)
		nodez(numIB,L) = nodezlocal(numIB,L) + Czor(numIB)
   	    if (mod(itime,n_out).eq.0) then
	if(nplot.eq.2) write(Geom_Time1,89)
     &		nodex(numIB,L),nodey(numIB,L),nodez(numIB,L)
    	    endif
	  enddo

	ENDIF !Horizontal axis
	ENDIF !Turbine
!--------------------------------------------------
!_----- NON-TURBINE BODY which is moving   -------
       IF (.NOT. ibturbine(numIB)) then		! Non-Turbine
	do L=1,nodes(numIB)
	 nodex(numIB,L)=
     &   R0(numIB,L)*DSIN(rads(numIB)+alpha0(numIB,L))+Cxor(numIB)
	 nodey(numIB,L)=
     &   R0(numIB,L)*DCOS(rads(numIB)+alpha0(numIB,L))+Cyor(numIB)

!	 nodex(numIB,L)=nodexlocal(numIB,L)*dcos(rads(numIB))-
!     &		 	nodeylocal(numIB,L)*dsin(rads(numIB))+Cxor(numIB)
!	 nodey(numIB,L)=nodexlocal(numIB,L)*dsin(rads(numIB))+
!     &		 	nodeylocal(numIB,L)*dcos(rads(numIB))+Cyor(numIB)
         if (mod(itime,n_out).eq.0) then
	if(nplot.eq.2)  write(Geom_Time1,89)
     &   nodex(numIB,L),nodey(numIB,L),nodez(numIB,L)
	 endif
	enddo
	if(nplot.eq.2 .and. mod(itime,n_out).eq.0)  close(Geom_Time1)
       ENDIF	!Not a turbine
!---------------------------------------------------

   88 FORMAT (i5)
   89 FORMAT (3f25.5)
        RETURN
        END SUBROUTINE
!#############################################################
      SUBROUTINE imb_moved_shades(numIB)
!#############################################################
      use vars
      use multidata
      use imb
      use mpi
      implicit none
      INTEGER, intent(in) :: numIB
      DOUBLE PRECISION:: PI,xtop,ytop,ztop
      INTEGER      :: L,I,K,strlen,strlen2,GT1,numnodes,ntri,ii,P
      CHARACTER*8  :: char_block,num_ib
      CHARACTER*31 :: gridfile1
       PI = 4.D0*DATAN(1.D0)

      if (mod(itime,n_out).ne.0) RETURN

      IF (myrank.ne.master) goto 797

	IF ((.NOT. ibturbine(numIB)) .and. turax(numIB).ne.1) RETURN !Only works for VAT
	 	K=nodes(numIB)/imbnumber(numIB) 	! Vertical Axis Turbine
         GT1=301
         write(char_block,'(I8)') itime
         strlen=LEN(TRIM(ADJUSTL(char_block)))
         char_block=REPEAT('0',(6-strlen))//TRIM(ADJUSTL(char_block))
           write(num_ib,'(I8)') numIB
           strlen2=LEN(TRIM(ADJUSTL(num_ib)))
           num_ib=REPEAT('0',(2-strlen2))//TRIM(ADJUSTL(num_ib))
           gridfile1='Blade_'//TRIM(ADJUSTL(num_ib))//
     &      '_Shade_'//TRIM(ADJUSTL(char_block))//'.plt'
         open (unit=GT1, file=gridfile1)
	   write(GT1,*)'TITLE = "Shaded blades"'
	   write(GT1,*)'VARIABLES="x","y","z"'
	   ntri=nscatter(numIB)*imbnumber(numIB)
	   write(GT1,*)'zone N=',(2*nscatter(numIB))*imbnumber(numIB),
     &    'E=',ntri,'DATAPACKING = POINT, ZONETYPE = FEQUADRILATERAL'
!Points writting
	Do P=1,imbnumber(numIB)
	  do L=1,nscatter(numIB)
	   ii=(P-1)*K+L
	   write(GT1,89)nodex(numIB,ii),nodey(numIB,ii),nodez(numIB,ii)
	  enddo
	  do L=1,nscatter(numIB)
   	   ii=(P-1)*K+L
!		if (axis(numIB).eq.3) then
		xtop=nodex(numIB,ii)
		ytop=nodey(numIB,ii)
           	if (linfin(numIB).eq.1) ztop=zen
           	if (linfin(numIB).eq.0) ztop=zend(numIB)
!		endif
!		if (axis(numIB).eq.-1) then
!		xtop=nodex(numIB,ii)
!		ytop=nodey(numIB,ii)
!           	ztop=nodez(numIB,ii)
!		endif
	   write (GT1,89)xtop,ytop,ztop
	  enddo
	Enddo !imbnumber
!Edges writting
	Do P=1,imbnumber(numIB)
	  do L=(2*(P-1))*nscatter(numIB)+1,(2*P-1)*nscatter(numIB)-1
	   write (GT1,88)L,L+1,nscatter(numIB)+L,nscatter(numIB)+L+1
	  enddo
	   write (GT1,88)
     &     (2*P-1)*nscatter(numIB),(2*(P-1))*nscatter(numIB)+1,
     &	   (2*P)*nscatter(numIB),(2*P-1)*nscatter(numIB)+1
	Enddo !imbnumber

	  close(GT1)

797	CONTINUE

   88 FORMAT (4i5)
   89 FORMAT (3e25.6)

        RETURN
        END SUBROUTINE


!======================================================================
       subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx, &
                       ql,qr,auxl,auxr,wave,s,amdq,apdq)
!======================================================================
!
! Solves normal Riemann problems for the adjoint of the linearized
! 2D shallow water equations with topography.
! Uses q-waves, not f-waves, since the forward solve is in conservation
! form using f-waves.
!
! The full nonlinear forward problem in the x-direction is:
!     h_t + (hu)_x = 0
!     (hu)_t + (h*u^2 + 0.5*g*h^2)_x = -g*h*B_x(x)
! where h is the depth, hu the momentum, and B(x) the topography/bathymetry.
!
! The linearized forward problem is:
!     eta_t + mom_x = 0
!     mom_t + [g*h0(x) * eta]_x = 0
! where (eta, mom) are the surface displacement eta and linearized momentum,
! and h0(x) is the background depth (ocean at rest), so h0(x) = max(-B(x), 0).
!
! Note the forward problem is in conservation form q_t + (A(x)q)_x = 0,
! so the adjoint equation is non-conservative and has the form
!     q_hat_t + A(x)^T q_hat_x = 0
! with coefficient matrix is
!     A(x)^T = [0  g*h0(x)]
!              [1     0   ]
!
! We need to solve the adjoint backwards in time, but we convert this into
! a problem going forward in time in order to apply GeoClaw, by solving
!     q_hat_t - A(x)^T q_hat_x = 0.
!
! Hence the Riemann solver uses the eigenvalues/vectors of -A(x)^T, which are:
!     lambda_1 = -c0,  r_1 = [+c0, 1]^T,
!     lambda_2 = +c0,  r_2 = [-c0, 1]^T.
!
! If h0 < drytol on one side of the interface, then "solid wall" BCs
! are used to find the single wave propagating into the ocean with mom=0 behind.
!
! On input, ql contains the state vector at the left edge of each cell
!     qr contains the state vector at the right edge of each cell
!
! This data is along a slice in the x-direction if ixy=1
!     or the y-direction if ixy=2.

!  Note that the i'th Riemann problem has left state qr(i-1,:)
!     and right state ql(i,:)
!  From the basic clawpack routines, this routine is called with
!     ql = qr
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                           !
!      # This Riemann solver is for the shallow water adjoint               !
!             equations. It is modified from rpn2_geoclaw.f.                !
!                                                                           !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      use geoclaw_module, only: g => grav, drytol => dry_tolerance
      use geoclaw_module, only: earth_radius, deg2rad
      use amr_module, only: mcapa, use_fwaves

      implicit none

      !input
      integer, intent(in) :: maxm,meqn,maux,mwaves,mbc,mx,ixy

      real(kind=8), intent(in) ::  ql(meqn, 1-mbc:maxm+mbc)
      real(kind=8), intent(in) ::  qr(meqn, 1-mbc:maxm+mbc)
      real(kind=8), intent(in) ::  auxl(maux,1-mbc:maxm+mbc)
      real(kind=8), intent(in) ::  auxr(maux,1-mbc:maxm+mbc)
      real(kind=8), intent(out) ::  wave(meqn, mwaves, 1-mbc:maxm+mbc)
      real(kind=8), intent(out) ::  s(mwaves, 1-mbc:maxm+mbc)
      real(kind=8), intent(out) ::  apdq(meqn,1-mbc:maxm+mbc)
      real(kind=8), intent(out) ::  amdq(meqn,1-mbc:maxm+mbc)

      ! local
      integer :: m,i,mu,nv
      real(kind=8) :: delta(2)
      real(kind=8) :: h0R,h0L,huR,huL,etaR,etaL
      real(kind=8) :: hR,hL,bR,bL,cL,cR,alf1,alf2,dxdc
      logical dryL,dryR

      if (mwaves .ne. 2) then
         write(6,*) '*** Adjoint solver requires num_waves = 2'
         stop
         endif

      if (use_fwaves) then
         write(6,*) '*** Adjoint solver requires use_fwaves=False'
         stop
         endif

      ! initialize for dry areas:
      wave(:,:,:) = 0.d0
      s(:,:) = 1.d0
      amdq(:,:) = 0.d0
      apdq(:,:) = 0.d0

      !loop through Riemann problems at each grid cell
      do i=2-mbc,mx+mbc

         ! background depth based on topography:
         bL = auxr(1,i-1)
         bR = auxl(1,i)
         h0L = max(-bL, 0.d0)
         h0R = max(-bR, 0.d0)

         !skip problem if in a completely dry area
         if (h0L <= drytol .and. h0R <= drytol) then
             cycle ! go to next i
         endif

         !set normal direction
         if (ixy.eq.1) then
            mu=2
            nv=3
         else
            mu=3
            nv=2
         endif

        ! linearized eta:
        hL = qr(1,i-1)
        hR = ql(1,i)
        etaL = hL + bL
        etaR = hR + bR

        ! linearized momenta:
        huL = qr(mu,i-1)
        huR = ql(mu,i)

        ! wave speeds
        cL = sqrt(g*h0L) ! 1 wave speed is -cL
        cR = sqrt(g*h0R) ! 2 wave speed is +cR

        ! Check for wet/dry boundary
        if (hR <= drytol) then
            ! set "ghost cell" values for zero momentum BC:
            etaR = etaL
            huR = -huL
            dryR = .true.
            cR = cL
        else
            dryR = .false.
        endif

        if (hL <= drytol) then
            ! set "ghost cell" values for zero momentum BC:
            etaL = etaR
            huL = -huR
            dryL = .true.
            cL = cR
        else
            dryL = .false.
        endif

        ! Roe average speeds
        ! More consistent with forward solver, but doesn't make much difference
        !cL = sqrt(g*0.5d0*(h0L+h0R)) ! 1 wave speed is -cL
        !cR = sqrt(g*0.5d0*(h0L+h0R)) ! 2 wave speed is +cR

        if ((cL<drytol) .and. (cR<drytol)) then
            ! should not happen
            write(6,*) '*** g,h0L,h0r: ',g,h0L,h0r
            endif

        !--------------------end initializing----------
        ! solve Riemann problem.

        ! q-wave splitting
        delta(1) = etaR - etaL
        delta(2) = huR - huL

        alf1 = (delta(1) + cR*delta(2))/(cL + cR)
        alf2 = (-delta(1) + cL*delta(2))/(cL + cR)

        ! eliminate one wave if dry to either side:
        if (dryL) alf1 = 0.d0
        if (dryR) alf2 = 0.d0

        ! Compute the waves.
        wave(1,1,i) = cL*alf1
        wave(mu,1,i) = alf1
        wave(nv,1,i) = 0.d0
        s(1,i) = -cL

        wave(1,2,i) = -cR*alf2
        wave(mu,2,i) = alf2
        wave(nv,2,i) = 0.d0
        s(2,i) = cR

!====== Adjust for mapping from latitude longitude to physical space====
        if (mcapa.gt.0) then
            if (ixy.eq.1) then
               dxdc=(earth_radius*deg2rad)
            else
               dxdc=earth_radius*cos(auxl(3,i))*deg2rad
            endif
            s(1,i) = dxdc * s(1,i)
            s(2,i) = dxdc * s(2,i)
        endif

        ! Fluctuations:
        ! 1-wave is always left-going, 2-wave is right-going
        amdq(1:meqn,i) = s(1,i) * wave(1:meqn,1,i)
        apdq(1:meqn,i) = s(2,i) * wave(1:meqn,2,i)

      enddo

      return
      end subroutine rpn2


      PROGRAM FSCORR
      PARAMETER (NHX=200)
      REAL H(NHX), M(NHX), LSQ(NHX), FUN(NHX), FCORR(NHX)
      REAL X(NHX), Y(NHX), Z(NHX)
C
      IDEV = 6
      SIZE = 8.0
      CH = 0.02
C
      HMAX = 10.0
      DH = 1.0
C
      FMAX = 0.5
      DF = 0.1
C
      PAR = 0.75
C
      HWT = 1.0/HMAX
      FWT = PAR/FMAX
C
      OPEN(7,FILE='hfun.fs',STATUS='OLD')
      DO 10 I=1, NHX
        READ(7,*,END=11) H(I),M(I),LSQ(I),FUN(I)
 10   CONTINUE
 11   CONTINUE
      N = I-1
      CLOSE(7)
C
      DO 20 I=1, N
        HB = 1.0/(H(I)-1.0)
ccc        F = 0.22*(1.0 - (5.0*HB-1.0)**2) + 0.5*HB - 0.05 + 3.0*HB**3
C
        F = -0.05 + 2.7*HB - 5.5*HB**2 + 3.0*HB**3
C
        HK = H(I)
ccc        TFS    =  (6.54*HK - 14.07   )/HK**2
c
        TFS  = 4.70*HB - 8.45*HB**2 + 3.41*HB**3
        AM = 2.0*F/TFS - 1.0
C
        Z(I) = M(I)
C
        Y(I) = AM
        X(I) = 10.0*HB

        FUN(I) = M(I)
        FCORR(I) = AM
C
CC        F = 0.5*(BUH + 1.0)*TFS
C
C        X(I) = 10.0*HB
CC
C        F = 0.395*(1.0 - 5.8*(HB-0.485)**2)
C        Y(I) = F
C        Z(I) = FUN(I)*4.0/H(I)
CC
C        FCORR(I) = 0.25*F*H(I)
C
 20   CONTINUE
C
C
      CALL PLOTS(0,-999,IDEV)
      CALL FACTOR(SIZE)
C
      CALL PLOT(8.0*CH,8.0*CH,-3)
C
      CALL PLOTON
C
      CALL XAXIS(0.0,0.0,1.0,DH*HWT,0.0,DH,CH,1)
      CALL YAXIS(0.0,0.0,PAR,DF*FWT,0.0,DF,CH,1)
C
      CALL XYPLOT(N,H,FUN  ,0.0,HWT,0.0,FWT,1,0.3*CH,+1)
      CALL XYPLOT(N,H,FCORR,0.0,HWT,0.0,FWT,1,0.3*CH, 0)
C
      CALL XYPLOT(N,X,Z,0.0,HWT,0.0,FWT,1,0.3*CH,+1)
      CALL XYPLOT(N,X,Y,0.0,HWT,0.0,FWT,1,0.3*CH, 0)
C
      CALL PLOTOF
C
      WRITE(*,*) 'Hit <cr>'
      READ(*,1000) ANS
 1000 FORMAT(A4)
C
      CALL PLOT(0.0,0.0,+999)
      STOP
      END


      subroutine hapkalbe(om,af,s0,h,
     s           brdfalb)
      parameter (nta=24,nfa=48)
      real teta1,teta2,phi1,phi2,ta(nta),fa(nfa),wta(nta),wfa(nfa)
      real om,af,s0,h,mu1,mu2
      real brdfalb,summ,si2,si1
      real fi,f,cg,h1,h2,h1h2,pg,p0,g,bg,pond
      real pi
      integer k,j,l
      pi=atan(1.)*4.
      teta1=0.
      teta2=pi/2.
      call gauss(teta1,teta2,ta,wta,nta)
      phi1=0.
      phi2=2.*pi
      call gauss(phi1,phi2,fa,wfa,nfa)
      brdfalb=0.
      summ=0.
      do 1 k=1,nfa
      do 2 j=1,nta
      do 3 l=1,nta
      mu2=cos(ta(j))
      mu1=cos(ta(l))
      si2=sin(ta(j))
      si1=sin(ta(l))
      fi=fa(k)
      f=om/4./(mu2+mu1)
      cg=mu1*mu2+sqrt(1.-mu1*mu1)*sqrt(1.-mu2*mu2)*cos(fi)
      h1=(1.+2*mu1)/(1.+2.*sqrt(1.-om)*mu1)
      h2=(1.+2*mu2)/(1.+2.*sqrt(1.-om)*mu2)
      h1h2=h1*h2
      pg=(1-af*af)/((1+af*af+2*af*cg)**1.5)
      p0=(1-af*af)/((1+af*af+2*af)**1.5)
      g=acos(cg)
      bg=(s0/(om*p0))/(1.+tan(g/2.)/h)
      pond=mu1*mu2*si1*si2*wfa(k)*wta(j)*wta(l)
      brdfalb=brdfalb+f*((1.+bg)*pg+h1h2-1.)*pond
      summ=summ+pond
  3   continue
  2   continue
  1   continue
      brdfalb=brdfalb/summ
      return
      end


! We don't expect multiple modules necessarily,
! but there should be at least one, containing the actual
! working code

MODULE functions

  USE kinds
  USE random_mod

  IMPLICIT NONE

  ! We probably don't need dbl for these problems
  ! but it  to get these right, but any way of
  ! obtaining it is OK

  CONTAINS

  SUBROUTINE setup_automaton_grid_random(grid)

    LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: grid
    INTEGER, DIMENSION(2) :: sz
    INTEGER(KIND=INT32) :: i, j
    REAL(KIND=REAL64) :: rand

    sz = SHAPE(grid)
    grid = .FALSE.

    ! Or setup random values

    DO j = 2, sz(2)-1
      DO i = 2, sz(1)-1
        rand = random()
        IF(rand .LT. 0.2) grid(i, j) = .TRUE.
      END DO
    END DO

  END SUBROUTINE setup_automaton_grid_random

  SUBROUTINE setup_automaton_grid_blob(grid)

    LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: grid
    INTEGER, DIMENSION(2) :: sz

    sz = SHAPE(grid)
    grid = .FALSE.

    ! Setup a blobby in the centre, 1/3rd the size of the grid
    ! For this, I don't bother to be careful about integer division
    grid(sz(1)/3+1:sz(1)*2/3, sz(2)/3+1:sz(2)*2/3) = .TRUE.

  END SUBROUTINE setup_automaton_grid_blob

  SUBROUTINE setup_automaton_grid_glider(grid)

    LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: grid
    INTEGER, DIMENSION(2) :: sz, base

    sz = SHAPE(grid)
    grid = .FALSE.

    base = sz/2
    ! Setup a single glider near the middle of the domain
    grid(base(1)+1:base(1)+3, base(2)) = .TRUE.
    grid(base(1)+3, base(2)+1) = .TRUE.
    grid(base(1)+2, base(2)+2) = .TRUE.

  END SUBROUTINE setup_automaton_grid_glider

  SUBROUTINE advance_automaton_grid(grid)

    LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: grid
    LOGICAL, DIMENSION(:,:), ALLOCATABLE :: new_grid

    INTEGER, DIMENSION(2) :: sz
    INTEGER(KIND=INT32) :: i, j, live_nb

    sz = SHAPE(grid)
    ALLOCATE(new_grid(sz(1), sz(2)))

    ! Clamp edges to .FALSE.
    new_grid(1:sz(1), 1) = .FALSE.
    new_grid(1:sz(1), sz(2)) = .FALSE.
    new_grid(1, 1:sz(2)) = .FALSE.
    new_grid(sz(1), 1:sz(2)) = .FALSE.

    ! Do the middle part
    DO j = 2, sz(2)-1
      DO i = 2, sz(1)-1
        ! Count live cells surrounding current cell

        ! Basic method using explicit additions (could also use a loop)
        ! I chose to format this with extra whitespace for readability
!        live_nb = 0
!        IF(grid(i-1, j-1)) live_nb = live_nb + 1
!        IF(grid(i-1, j))   live_nb = live_nb + 1
!        IF(grid(i-1, j+1)) live_nb = live_nb + 1
!        IF(grid(i,   j-1)) live_nb = live_nb + 1
!        IF(grid(i,   j+1)) live_nb = live_nb + 1
!        IF(grid(i+1, j-1)) live_nb = live_nb + 1
!        IF(grid(i+1, j))   live_nb = live_nb + 1
!        IF(grid(i+1, j+1)) live_nb = live_nb + 1

        ! Cleverer update using an array slice and Intrinsic
        live_nb = COUNT(grid(i-1:i+1, j-1:j+1))
        IF(grid(i, j)) live_nb = live_nb - 1

        ! Do updates according to number of neighbours
        IF(grid(i, j) .AND. live_nb .LT. 2) THEN
          new_grid(i, j) = .FALSE.
        ELSE IF(grid(i, j) .AND. live_nb .GT. 3) THEN
          new_grid(i, j) = .FALSE.
        ELSE IF(.NOT. grid(i, j) .AND. live_nb .EQ. 3) THEN
          new_grid(i, j) = .TRUE.
        ELSE
          new_grid(i, j) = grid(i, j)
        END IF

      END DO

    END DO

    !After doing all steps, copy the new state back
    grid = new_grid

    !We can free new_grid now, but we don't actually NEED to
    DEALLOCATE(new_grid)

  END SUBROUTINE advance_automaton_grid

END MODULE functions

PROGRAM main

  USE kinds
  !Provided pretty printing module
  USE ascii_display
  USE sleep_mod
  USE command_line

  USE functions

  IMPLICIT NONE

  INTEGER(KIND=INT32) :: N, T
  INTEGER(KIND=INT32) :: i
  LOGICAL, DIMENSION(:,:), ALLOCATABLE :: grid
  LOGICAL :: success
  CHARACTER :: init

  ! Get command line arguments, and if N or T are given, use them
  CALL parse_args
  ! If not given, we should use sensible defaults for the grid size
  ! and number of iterations

  ! Best and simplest way to use cmd line module
  success = get_arg("T", T)
  IF( .NOT. success) THEN
    T = 20
  END IF

  ! Or in super-short form
  IF( .NOT. get_arg("N", N)) THEN
    N = 45
  END IF

  ALLOCATE(grid(2*N, N))

  ! As specified in the brief,
  ! I use a single-character flag for the initial state,
  ! either 'R' for random, 'B' for blob
  ! and I default to random if not given or not one of the options
  success = get_arg("init", init)

  IF(init == "B" .OR. init == "b") THEN
    ! Blob in centre of domain
    CALL setup_automaton_grid_blob(grid)
  ELSE  IF(init == "G" .OR. init == "g") THEN
    ! Blob in centre of domain
    CALL setup_automaton_grid_glider(grid)
  ELSE
    ! This will set random states
    CALL setup_automaton_grid_random(grid)
  END IF

  CALL display_array(grid, .TRUE.)
  CALL wait_for_enter_key

  DO i = 1, T

    CALL advance_automaton_grid(grid)
    CALL display_array(grid, .TRUE.)
    !CALL wait_for_enter_key
    CALL sleep_sec(1)
  END DO

END PROGRAM


!##############################################################################
!# ****************************************************************************
!# <name> cccallback </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains callback functions for the cc2d-mini problem that are
!# used during the matrix/vector assembly for specifying analytical data.
!# There are three callback functions involved, which may be called depending
!# on the situation. All of them correspond to a specific interface for
!# callback functions, defined in 'intf_xxxx.inc' files.
!#
!# 1.) coeff_Stokes
!#     -> Returns the coefficients for the Laplace matrix. This routine is
!#        only used if the problem to calculate has nonconstant coefficients!
!#        Otherwise the routine is dead.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientMatrixSc.inc'
!#
!# 1.) coeff_Pressure
!#     -> Returns the coefficients for the pressure matrix. This routine is
!#        only used if the problem to calculate has nonconstant coefficients!
!#        Otherwise the routine is dead.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientMatrixSc.inc'
!#
!# 2.) coeff_RHS_x
!#     -> Returns analytical values for the right hand side of the X-velocity
!#        equation.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 3.) coeff_RHS_y
!#     -> Returns analytical values for the right hand side of the Y-velocity
!#        equation.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 4.) coeff_RHS_z
!#     -> Returns analytical values for the right hand side of the Z-velocity
!#        equation.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 5.) ffunction_TargetX
!#     -> Returns analytical values for the desired flow field in X-direction.
!#     -> Is used for error analysis during the postprocessing.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 6.) ffunction_TargetY
!#     -> Returns analytical values for the desired flow field in Y-direction.
!#     -> Is used for error analysis during the postprocessing.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 7.) ffunction_TargetZ
!#     -> Returns analytical values for the desired flow field in Z-direction.
!#     -> Is used for error analysis during the postprocessing.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 8.) ffunction_TargetP
!#     -> Returns analytical values for the desired pressure.
!#     -> Is used for error analysis during the postprocessing.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 11.) cc_initCollectForAssembly
!#     -> Is called prior to the assembly process.
!#     -> Stores some information from the problem structure to a collection
!#        such that it can be accessed in callback routines
!#
!# 12.) cc_doneCollectForAssembly
!#      -> Is called after the assembly process.
!#      -> Releases information stored in the collection by
!#         cc_initCollectForAssembly.
!#
!# For nonstationary simulation, it might be neccessary in these routines
!# to access the current simulation time. Before the assembly process, the cc2d
!# framework calls cc_initCollectForAssembly to stores the current point
!# in time (and probably other necessary information) to the quickaccess-array
!# in the collection which is passed to the callback routines. The callback
!# routines can access this as follows:
!#
!# -> rcollection%IquickAccess(1)   = 0: stationary,
!#                                    1: nonstationary with explicit time stepping
!# -> rcollection%DquickAccess(1)   = current simulation time
!# -> rcollection%DquickAccess(2)   = minimum simulation time
!# -> rcollection%DquickAccess(3)   = maximum simulation time
!#
!# After the assembly, cc_doneCollectForAssembly is called to clean up.
!# Note: Information stored in the quick-access array are of temporary
!# nature and does not have to be cleaned up.
!#
!# </purpose>
!##############################################################################

module cccallback

  use fsystem
  use storage
  use linearsolver
  use bilinearformevaluation
  use linearformevaluation
  use cubature
  use matrixfilters
  use vectorfilters
  use bcassembly
  use mprimitives
  use meshregion

  use ccbasic

  implicit none

contains

! ***************************************************************************

!<subroutine>

  subroutine cc_initCollectForAssembly (rproblem,rcollection)

!<description>
  ! This subroutine is an auxiliary subroutine called by the CC2D framework
  ! and has usually not to be changed by the user.
  !
  ! The subroutine prepares the collection rcollection to be passed to callback
  ! routines for assembling boundary conditions or RHS vectors. It is
  ! called directly prior to the assembly to store problem-specific information
  ! in the quick-access arrays of the collection.
  ! Basically speaking, the routine stores information about whether thw problem
  ! is stationary, nonstationary or about the current simulation time.
!</description>

!<input>
  ! Problem structure with all problem relevant data.
  type(t_problem), intent(in) :: rproblem
!</input>

!<inputoutput>
  ! Collection structure to be initialised.
  type(t_collection), intent(inout) :: rcollection
!</inputoutput>

!</subroutine>

    ! In a nonstationary simulation, save the simulation time as well as the
    ! minimum and maximum time to the quick-access array of the collection,
    ! so it can be accessed in the callback routines!
    rcollection%Iquickaccess(1) = rproblem%itimedependence
    select case (rproblem%itimedependence)
    case (0)
      ! Stationary simulation
      rcollection%Dquickaccess(1) = 0.0_DP
      rcollection%Dquickaccess(2) = 0.0_DP
      rcollection%Dquickaccess(3) = 0.0_DP
    case (1)
      rcollection%Dquickaccess(1) = rproblem%rtimedependence%dtime
      rcollection%Dquickaccess(2) = rproblem%rtimedependence%dtimeInit
      rcollection%Dquickaccess(3) = rproblem%rtimedependence%dtimeMax
    end select

  end subroutine

! ***************************************************************************

!<subroutine>

  subroutine cc_doneCollectForAssembly (rproblem,rcollection)

!<description>
  ! This subroutine is an auxiliary subroutine called by the CC2D framework
  ! and has usually not to be changed by the user.
  !
  ! After the assembly process, this subroutine is called to release temporary
  ! information from the collection which was stored there by
  ! cc_initCollectForAssembly.
!</description>

!<input>
  ! Problem structure with all problem relevant data.
  type(t_problem), intent(in) :: rproblem
!</input>

!<inputoutput>
  ! Collection structure to be cleaned up.
  type(t_collection), intent(inout) :: rcollection
!</inputoutput>

!</subroutine>

    ! Currently, this subroutine is empty as all information stored in
    ! the collection in cc_initCollectForAssembly is put to the quick-access
    ! arrays -- which do not have to be cleaned up.
    ! This might change in future...

  end subroutine

! ***************************************************************************
  !<subroutine>

  subroutine coeff_Stokes (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset, &
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It has to compute
    ! the coefficients in front of the terms of the bilinear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the bilinear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the bilinear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

    ! The bilinear form which is currently being evaluated:
    type(t_bilinearForm), intent(in)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(in)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(in)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(in)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in trial space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(inout), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(out)                      :: Dcoefficients
  !</output>

  !</subroutine>

    ! Routine is not called anyway in case of constant coefficients!
    Dcoefficients = 1.0_DP

  end subroutine

! ***************************************************************************
  !<subroutine>

  subroutine coeff_Pressure (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset, &
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It has to compute
    ! the coefficients in front of the terms of the bilinear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the bilinear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the bilinear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

    ! The bilinear form which is currently being evaluated:
    type(t_bilinearForm), intent(in)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(in)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(in)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(in)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in trial space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(inout), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(out)                      :: Dcoefficients
  !</output>

  !</subroutine>

    ! Routine is not called anyway in case of constant coefficients!
    Dcoefficients = 1.0_DP

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine coeff_RHS_x (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTest,rdomainIntSubset,&
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the vector assembly. It has to compute
    ! the coefficients in front of the terms of the linear form of the
    ! X-velocity part of the right hand side vector.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the linear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the linear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

    ! The linear form which is currently to be evaluated:
    type(t_linearForm), intent(in)                              :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(in)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(in)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(in)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(inout), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the linear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the linear form.
    real(DP), dimension(:,:,:), intent(out)                      :: Dcoefficients
  !</output>

  !</subroutine>

    real(DP) :: dtime

    ! In a nonstationary simulation, one can get the simulation time
    ! with the quick-access array of the collection.
    if (present(rcollection)) then
      dtime = rcollection%Dquickaccess(1)
    else
      dtime = 0.0_DP
    end if

    Dcoefficients(:,:,:) = 0.0_DP

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine coeff_RHS_y (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTest,rdomainIntSubset,&
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the vector assembly. It has to compute
    ! the coefficients in front of the terms of the linear form of the
    ! Y-velocity part of the right hand side vector.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the linear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the linear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

    ! The linear form which is currently to be evaluated:
    type(t_linearForm), intent(in)                              :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(in)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(in)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(in)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(inout), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the linear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the linear form.
    real(DP), dimension(:,:,:), intent(out)                      :: Dcoefficients
  !</output>

  !</subroutine>

    real(DP) :: dtime

    ! In a nonstationary simulation, one can get the simulation time
    ! with the quick-access array of the collection.
    if (present(rcollection)) then
      dtime = rcollection%Dquickaccess(1)
    else
      dtime = 0.0_DP
    end if

    Dcoefficients(:,:,:) = 0.0_DP

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine coeff_RHS_z (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTest,rdomainIntSubset,&
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the vector assembly. It has to compute
    ! the coefficients in front of the terms of the linear form of the
    ! Z-velocity part of the right hand side vector.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the linear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the linear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

    ! The linear form which is currently to be evaluated:
    type(t_linearForm), intent(in)                              :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(in)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(in)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(in)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(inout), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the linear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the linear form.
    real(DP), dimension(:,:,:), intent(out)                      :: Dcoefficients
  !</output>

  !</subroutine>

    real(DP) :: dtime

    ! In a nonstationary simulation, one can get the simulation time
    ! with the quick-access array of the collection.
    if (present(rcollection)) then
      dtime = rcollection%Dquickaccess(1)
    else
      dtime = 0.0_DP
    end if

    Dcoefficients(:,:,:) = 0.0_DP

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine ffunction_TargetX (cderivative,rdiscretisation, &
                nelements,npointsPerElement,Dpoints, &
                IdofsTest,rdomainIntSubset,&
                Dvalues,rcollection)

  use basicgeometry
  use triangulation
  use collection
  use scalarpde
  use domainintegration

!<description>
  ! This subroutine is called during the postprocessing.
  ! It should return values of the analytical solution (if it is known).
  ! These are compared with the calculated solution to calculate the
  ! error in the X-velocity.
  !
  ! If the analytical solution is unknown, this routine doesn't make sense.
  ! In this case, error analysis should be deactivated in the .DAT files!
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(in)                                         :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in)                                         :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in)                                         :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM3D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in)  :: Dpoints

  ! An array accepting the DOF's on all elements trial in the trial space.
  ! DIMENSION(\#local DOF's in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It's usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

  ! A pointer to a collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional      :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out)                      :: Dvalues
!</output>

!</subroutine>

    real(DP) :: dtime,dtimeMax
    integer :: itimedependence

    ! In a nonstationary simulation, one can get the simulation time
    ! with the quick-access array of the collection.
    if (present(rcollection)) then
      dtime = rcollection%Dquickaccess(1)
      dtimeMax = rcollection%Dquickaccess(3)
      itimedependence = rcollection%Iquickaccess(1)
    else
      itimedependence = 0
      dtime = 0.0_DP
      dtimeMax = 0.0_DP
    end if

    Dvalues(:,:) = 0.0_DP

    ! Example:
    ! IF (cderivative .EQ. DER_FUNC) THEN
    !   Dvalues(:,:) = (-dtime**2/100.+dtime/5.)*(Dpoints(1,:,:))
    ! END IF

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine ffunction_TargetY (cderivative,rdiscretisation, &
                nelements,npointsPerElement,Dpoints, &
                IdofsTest,rdomainIntSubset,&
                Dvalues,rcollection)

  use basicgeometry
  use triangulation
  use collection
  use scalarpde
  use domainintegration

!<description>
  ! This subroutine is called during the postprocessing.
  ! It should return values of the analytical solution (if it is known).
  ! These are compared with the calculated solution to calculate the
  ! error in the Y-velocity.
  !
  ! If the analytical solution is unknown, this routine doesn't make sense.
  ! In this case, error analysis should be deactivated in the .DAT files!
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(in)                                         :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in)                                         :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in)                                         :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM3D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in)  :: Dpoints

  ! An array accepting the DOF's on all elements trial in the trial space.
  ! DIMENSION(\#local DOF's in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It's usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

  ! A pointer to a collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional      :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out)                      :: Dvalues
!</output>

!</subroutine>

    real(DP) :: dtime,dtimeMax
    integer :: itimedependence

    ! In a nonstationary simulation, one can get the simulation time
    ! with the quick-access array of the collection.
    if (present(rcollection)) then
      dtime = rcollection%Dquickaccess(1)
      dtimeMax = rcollection%Dquickaccess(3)
      itimedependence = rcollection%Iquickaccess(1)
    else
      itimedependence = 0
      dtime = 0.0_DP
      dtimeMax = 0.0_DP
    end if

    Dvalues(:,:) = 0.0_DP

    ! Example:
    ! IF (cderivative .EQ. DER_FUNC) THEN
    !   Dvalues(:,:) = (-dtime**2/100.+dtime/5.)*(-Dpoints(2,:,:))
    ! END IF

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine ffunction_TargetZ (cderivative,rdiscretisation, &
                nelements,npointsPerElement,Dpoints, &
                IdofsTest,rdomainIntSubset,&
                Dvalues,rcollection)

  use basicgeometry
  use triangulation
  use collection
  use scalarpde
  use domainintegration

!<description>
  ! This subroutine is called during the postprocessing.
  ! It should return values of the analytical solution (if it is known).
  ! These are compared with the calculated solution to calculate the
  ! error in the Z-velocity.
  !
  ! If the analytical solution is unknown, this routine doesn't make sense.
  ! In this case, error analysis should be deactivated in the .DAT files!
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(in)                                         :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in)                                         :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in)                                         :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM3D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in)  :: Dpoints

  ! An array accepting the DOF's on all elements trial in the trial space.
  ! DIMENSION(\#local DOF's in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It's usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

  ! A pointer to a collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional      :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out)                      :: Dvalues
!</output>

!</subroutine>

    real(DP) :: dtime,dtimeMax
    integer :: itimedependence

    ! In a nonstationary simulation, one can get the simulation time
    ! with the quick-access array of the collection.
    if (present(rcollection)) then
      dtime = rcollection%Dquickaccess(1)
      dtimeMax = rcollection%Dquickaccess(3)
      itimedependence = rcollection%Iquickaccess(1)
    else
      itimedependence = 0
      dtime = 0.0_DP
      dtimeMax = 0.0_DP
    end if

    Dvalues(:,:) = 0.0_DP

    ! Example:
    ! IF (cderivative .EQ. DER_FUNC) THEN
    !   Dvalues(:,:) = (-dtime**2/100.+dtime/5.)*(-Dpoints(2,:,:))
    ! END IF

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine ffunction_TargetP (cderivative,rdiscretisation, &
                nelements,npointsPerElement,Dpoints, &
                IdofsTest,rdomainIntSubset,&
                Dvalues,rcollection)

  use basicgeometry
  use triangulation
  use collection
  use scalarpde
  use domainintegration

!<description>
  ! This subroutine is called during the postprocessing.
  ! It should return values of the analytical solution (if it is known).
  ! These are compared with the calculated solution to calculate the
  ! error in the pressure
  !
  ! If the analytical solution is unknown, this routine doesn't make sense.
  ! In this case, error analysis should be deactivated in the .DAT files!
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(in)                                         :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in)                                         :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in)                                         :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM3D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in)  :: Dpoints

  ! An array accepting the DOF's on all elements trial in the trial space.
  ! DIMENSION(\#local DOF's in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It's usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

  ! A pointer to a collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional      :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out)                      :: Dvalues
!</output>

!</subroutine>

    real(DP) :: dtime,dtimeMax
    integer :: itimedependence

    ! In a nonstationary simulation, one can get the simulation time
    ! with the quick-access array of the collection.
    if (present(rcollection)) then
      dtime = rcollection%Dquickaccess(1)
      dtimeMax = rcollection%Dquickaccess(3)
      itimedependence = rcollection%Iquickaccess(1)
    else
      itimedependence = 0
      dtime = 0.0_DP
      dtimeMax = 0.0_DP
    end if

    Dvalues(:,:) = 0.0_DP

    ! Example:
    ! IF (cderivative .EQ. DER_FUNC) THEN
    !   ...
    ! END IF

  end subroutine

  ! ***************************************************************************
  ! Values on the real boundary, described by a mesh region

!<subroutine>

  subroutine getBoundaryValues (sexpressionName,icomponent,rdiscretisation,&
                                rboundaryRegion,Dcoords, dvalue, rcollection)

  use collection
  use spatialdiscretisation
  use discretebc

!<description>
  ! This routine is called for all segments on the real boundary which are
  ! marked in the DAT file with "evaluate expression of type -2".
  ! sexpressionName is the name of the expression from the DAT file.
  ! The other parameters define the current position on the boundary.
  ! The routine has to return a value which is used as the result of an
  ! expression, e.g. as Dirichlet value on the boundary.
  !
  ! The routine is allowed to return SYS_INFINITY_DP. The behaviour of this
  ! value depends on the type of boundary conditions. For Dirichlet
  ! boundary segments, all points where SYS_INFINITY_DP is returned are
  ! treated as Neumann points.
!</description>

!<input>
  ! Name of the expression to be evaluated. This name is configured in the
  ! DAT file for the boundary conditions.
  character(LEN=*), intent(in)                   :: sexpressionName

  ! Solution component that is currently being processed.
  ! 1 = X-velocity, 2 = y-velocity,...
  integer, intent(in)                            :: icomponent

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation, etc.
  type(t_spatialDiscretisation), intent(in)      :: rdiscretisation

  ! Mesh region that is currently being processed.
  type(t_meshRegion), intent(in)                 :: rboundaryRegion

  ! The coordinates of the point
  real(DP), dimension(:), intent(in)             :: Dcoords

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional    :: rcollection
!</input>

!<output>
  ! Return value of the expression. May be SYS_INFINITY_DP.
  real(DP), intent(out)                          :: dvalue
!</output>

!</subroutine>

    ! Return zero here
    dvalue = 0.0_DP

  end subroutine

end module


      H = A + B
      IF (blah) H = 3*H - 7