text:
c=======================================================================
      subroutine hdpmdensity (nrec,nvar,nstudy,
     &                        study,y,
     &                        ngrid,grid,
     &                        nu,nub,
     &                        a0b0,tinv,m0,prec0,tbinv,aebe,pieps,
     &                        sameps,sammu,samsb,
     &                        ncluster,ss,sc,alpha,muclus,sigma,mub,
     &                        sigmab,eps,
     &                        mcmc,nsave,seed,
     &                        densmc,densms,thetasave,randsave,
     &                        cstrt,ccluster,scstrt,sccluster,
     &                        iflagp,ywork,muwork,sigmainv,sigmabinv,
     &                        sigmawork,prob,quadf,workm1,
     &                        workmh1,workmh2,workv1)
c=======================================================================
c     # 47
c
c     Subroutine `hdpmdensity' to run a Markov chain in a
c     hierarchical DPM of normals model for density
c     estimation.
c
c     Copyright: Alejandro Jara, 2009-2010.
c
c     Version 2.0
c
c     Last modification: 14-05-2010.
c
c     Changes and Bug fixes:
c
c     Version 1.0 to Version 2.0:
c          - Bug in computing mean vector for new cluster. Thanks to
c            Ana Paula Sales for reporting the bug.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2 of the License, or (at
c     your option) any later version.
c
c     This program is distributed in the hope that it will be useful, but
c     WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
c     General Public License for more details.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
c
c     The author's contact information:
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c=======================================================================

      implicit none
c++++ data
      integer nrec,nvar,nstudy
      integer study(nrec)
      real*8 y(nrec,nvar)

c++++ prediction
      integer ngrid
      real*8 grid(ngrid,nvar)

c++++ prior
      integer nu,nub,sameps,sammu,samsb
      real*8 a0b0(nstudy+1,2)
      real*8 tinv(nvar,nvar)
      real*8 m0(nvar),prec0(nvar,nvar)
      real*8 tbinv(nvar,nvar)
      real*8 aebe(2)
      real*8 pieps(2)

c++++ current value
      integer ncluster
      integer ss(nrec)
      integer sc(nrec)
      real*8 alpha(nstudy+1)
      real*8 muclus(nrec+100,nvar)
      real*8 sigma(nvar,nvar)
      real*8 mub(nvar)
      real*8 sigmab(nvar,nvar)
      real*8 eps

c++++ mcmc
      integer mcmc(3),nburn,nskip,nsave,ndisplay

c++++ output
      real*8 densmc(nstudy+1,nvar*ngrid)
      real*8 densms(nstudy,nvar*ngrid)
      real*8 thetasave(nsave,nvar*(nvar+1)+1+
     &                 nstudy+1+nvar)
      real*8 randsave(nsave,nstudy)

c++++ seeds
      integer seed1,seed2,seed(2)

c++++ external working space
      integer cstrt(nrec,nrec)
      integer ccluster(nrec)
      integer scstrt(nstudy+1,nrec)
      integer sccluster(nstudy+1)
      integer iflagp(nvar)
      real*8 ywork(nvar)
      real*8 muwork(nvar)
      real*8 sigmainv(nvar,nvar)
      real*8 sigmabinv(nvar,nvar)
      real*8 sigmawork(nvar,nvar)
      real*8 prob(nrec+100)
      real*8 quadf(nvar,nvar)
      real*8 workm1(nvar,nvar)
      real*8 workmh1(nvar*(nvar+1)/2)
      real*8 workmh2(nvar*(nvar+1)/2)
      real*8 workv1(nvar)

c++++ internal working space - General
      integer i,ii,j,jj,k,kk,l,ok
      integer dispcount
      integer evali
      integer iscan
      integer isave
      integer ns
      integer nscan
      integer since
      integer skipcount
      integer sprint
      real*8 dnrm
      real*8 tmp1,tmp2,tmp3,tmp4,tmp5
      real*8 rbeta,lbetaf

c++++ internal working space - WDP
      integer studyind
      integer nj,n0,n1
      integer ncj,nc0

c++++ CPU time
      real*8 sec00,sec0,sec1,sec

c++++++++++++++++++++++++++
c     initialize variables
c++++++++++++++++++++++++++

c++++ mcmc, priors and "zipped"

      nburn=mcmc(1)
      nskip=mcmc(2)
      ndisplay=mcmc(3)

      seed1=seed(1)
      seed2=seed(2)

c++++ set random number generator

      call setall(seed1,seed2)

c++++ start the MCMC algorithm

      isave=0
      skipcount=0
      dispcount=0
      nscan=nburn+(nskip+1)*nsave

      call cpu_time(sec0)
      sec00=0.0

c++++ cluster structure

      do i=1,nrec
         ccluster(ss(i))=ccluster(ss(i))+1
         cstrt(ss(i),ccluster(ss(i)))=i
      end do

      do i=1,ncluster
         sccluster(sc(i))=sccluster(sc(i))+1
         scstrt(sc(i),sccluster(sc(i)))=i
      end do

c++++ inverse of the kernel covariance
      do i=1,nvar
         do j=1,nvar
            sigmainv(i,j)=sigma(i,j)
            sigmabinv(i,j)=sigmab(i,j)
         end do
      end do
      call inverse(sigmainv,nvar,iflagp)
      call inverse(sigmabinv,nvar,iflagp)

c      call dblepr("sigmainv",-1,sigmainv,nvar*nvar)
c      call dblepr("sigmabinv",-1,sigmabinv,nvar*nvar)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ start the MCMC algorithm
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      isave=0
      skipcount=0
      dispcount=0
      nscan=nburn+(nskip+1)*(nsave)

      call cpu_time(sec0)
      sec00=0.d0

      do iscan=1,nscan

c+++++++ check if the user has requested an interrupt
         call rchkusr()

c++++++++++++++++++++++++++++++++++++++++
c+++++++ clustering structure         +++
c++++++++++++++++++++++++++++++++++++++++

         do i=1,nrec

c++++++++++ check if the user has requested an interrupt
            call rchkusr()

            do j=1,nvar
               ywork(j)=y(i,j)
            end do
            studyind=study(i)

            ns=ccluster(ss(i))

            if(ns.gt.1)then
               ccluster(ss(i))=ccluster(ss(i))-1
               j=1
               ok=0
               do while(ok.eq.0.and.j.le.ns)
                  if(cstrt(ss(i),j).eq.i)ok=j
                  j=j+1
               end do
               if(ok.lt.ns)then
                  do j=ok,ns-1
                     cstrt(ss(i),j)=cstrt(ss(i),j+1)
                  end do
               end if
               cstrt(ss(i),ns)=0
             else

               since=ss(i)

               if(since.lt.ncluster)then
                  call relabelwdpm(i,since,nrec,nvar,nstudy,
     &                             ncluster,
     &                             ss,cstrt,ccluster,
     &                             sc,muclus)

                else
                  sc(ncluster)=0
                  do k=1,nvar
                     muclus(ncluster,k)=0.d0
                  end do
                  ccluster(ncluster)=0
                  ncluster=ncluster-1
               end if

               do k=1,nstudy+1
                  sccluster(k)=0
               end do

               do k=1,ncluster
                  sccluster(sc(k))=sccluster(sc(k))+1
                  scstrt(sc(k),sccluster(sc(k)))=k
               end do

            end if

            nj=0
            ncj=sccluster(studyind)
            if(ncj.gt.0)then
               do j=1,ncj
                  ii=scstrt(studyind,j)
                  nj=nj+ccluster(ii)
               end do
            end if

            n0=0
            nc0=sccluster(nstudy+1)
            if(nc0.gt.0)then
               do j=1,nc0
                  ii=scstrt(nstudy+1,j)
                  n0=n0+ccluster(ii)
               end do
            end if

            if(ncj.gt.0)then
               do j=1,ncj
                  ii=scstrt(studyind,j)
                  do k=1,nvar
                     muwork(k)=muclus(ii,k)
                     do l=1,nvar
                        sigmawork(k,l)=sigma(k,l)
                     end do
                  end do
                  call dmvnd(nvar,ywork,muwork,sigmawork,tmp2,iflagp)
                  prob(j)=exp(tmp2)*(1.d0-eps)*
     &                 dble(ccluster(ii))/(alpha(studyind)+dble(nj))
               end do
            end if

            if(nc0.gt.0)then
               do j=1,nc0
                  ii=scstrt(nstudy+1,j)
                  do k=1,nvar
                     muwork(k)=muclus(ii,k)
                     do l=1,nvar
                        sigmawork(k,l)=sigma(k,l)
                     end do
                  end do
                  call dmvnd(nvar,ywork,muwork,sigmawork,tmp2,iflagp)
                  prob(ncj+j)=exp(tmp2)*eps*
     &                dble(ccluster(ii))/(alpha(nstudy+1)+dble(n0))
               end do
            end if

            do k=1,nvar
               muwork(k)=mub(k)
               do l=1,nvar
                  sigmawork(k,l)=sigma(k,l)+sigmab(k,l)
               end do
            end do
            call dmvnd(nvar,ywork,muwork,sigmawork,tmp2,iflagp)
            prob(ncj+nc0+1)=exp(tmp2)*(1.d0-eps)*
     &                      alpha(studyind)/(alpha(studyind)+dble(nj))

            do k=1,nvar
               muwork(k)=mub(k)
               do l=1,nvar
                  sigmawork(k,l)=sigma(k,l)+sigmab(k,l)
               end do
            end do
            call dmvnd(nvar,ywork,muwork,sigmawork,tmp2,iflagp)
            prob(ncj+nc0+2)=exp(tmp2)*eps*
     &                      alpha(nstudy+1)/(alpha(nstudy+1)+dble(n0))

            call simdisc(prob,nrec+100,ncj+nc0+2,evali)

            if(evali.le.ncj)then
               ii=scstrt(studyind,evali)
               ss(i)=ii
               ccluster(ii)=ccluster(ii)+1
               cstrt(ii,ccluster(ii))=i

            else if(evali.gt.ncj.and.evali.le.(ncj+nc0))then
               ii=scstrt(nstudy+1,evali-ncj)
               ss(i)=ii
               ccluster(ii)=ccluster(ii)+1
               cstrt(ii,ccluster(ii))=i

            else
               ncluster=ncluster+1

               do k=1,nvar
                  tmp1=0.d0
                  tmp2=0.d0
                  do l=1,nvar
                     workm1(k,l)=sigmabinv(k,l)+sigmainv(k,l)
                     tmp1=tmp1+sigmainv(k,l)*ywork(l)
                     tmp2=tmp2+sigmabinv(k,l)*mub(l)
                  end do
                  workv1(k)=tmp1+tmp2
               end do
               call inverse(workm1,nvar,iflagp)
               do k=1,nvar
                  tmp1=0.d0
                  do l=1,nvar
                     tmp1=tmp1+workm1(k,l)*workv1(l)
                  end do
                  muwork(k)=tmp1
               end do

               call rmvnorm(nvar,muwork,workm1,workmh1,workv1,ywork)

               do k=1,nvar
                  muclus(ncluster,k)=ywork(k)
               end do

               ss(i)=ncluster
               ccluster(ncluster)=1
               cstrt(ncluster,ccluster(ncluster))=i

               if(evali.eq.(ncj+nc0+1))then
                  sc(ncluster)=studyind
                  sccluster(studyind)=sccluster(studyind)+1
                  scstrt(studyind,sccluster(studyind))=ncluster
               else
                  sc(ncluster)=nstudy+1
                  sccluster(nstudy+1)=sccluster(nstudy+1)+1
                  scstrt(nstudy+1,sccluster(nstudy+1))=ncluster
               end if
            end if

         end do

c         call intpr("ncluster",-1,ncluster,1)
c         call intpr("ss",-1,ss,nrec)
c         call intpr("sc",-1,sc,ncluster)
c         call intpr("ccluster",-1,ccluster,ncluster)
c         call intpr("sccluster",-1,sccluster,nstudy+1)

c++++++++++++++++++++++++++++++++++++++++
c+++++++ resampling cluster locations +++
c++++++++++++++++++++++++++++++++++++++++

         do ii=1,nstudy+1

c++++++++++ check if the user has requested an interrupt
            call rchkusr()

            ns=sccluster(ii)

c            call intpr("DP",-1,ii,1)
c            call intpr("ns",-1,ns,1)

            if(ns.gt.0)then

               do jj=1,ns

c++++++++++++++++ check if the user has requested an interrupt
                  call rchkusr()

                  kk=scstrt(ii,jj)

c                  call intpr("cluster",-1,kk,1)

                  n0=ccluster(kk)

                  do i=1,nvar
                     tmp1=0.d0
                     do j=1,nvar
                        quadf(i,j)=sigmabinv(i,j)+
     &                             dble(n0)*sigmainv(i,j)
                        tmp1=tmp1+sigmabinv(i,j)*mub(j)
                     end do
                     workv1(i)=tmp1
                  end do
                  call inverse(quadf,nvar,iflagp)

                  do i=1,n0
                     do j=1,nvar
                        tmp1=0.d0
                        do k=1,nvar
                           tmp1=tmp1+sigmainv(j,k)*y(cstrt(kk,i),k)
                        end do
                        workv1(j)=workv1(j)+tmp1
                     end do
                  end do

                  do i=1,nvar
                     tmp1=0.d0
                     do j=1,nvar
                        tmp1=tmp1+quadf(i,j)*workv1(j)
                     end do
                     ywork(i)=tmp1
                  end do

                  call rmvnorm(nvar,ywork,quadf,workmh1,workv1,muwork)

                  do i=1,nvar
                     muclus(kk,i)=muwork(i)
                  end do

c                  call dblepr("mu",-1,muwork,nvar)

               end do
            end if
         end do

c++++++++++++++++++++++++++++++++++++++++
c+++++++ kernel covariance matrix     +++
c++++++++++++++++++++++++++++++++++++++++

c+++++++ check if the user has requested an interrupt
         call rchkusr()

         if(nu.gt.0)then
            do i=1,nvar
               do j=1,nvar
                  quadf(i,j)=0.d0
               end do
            end do

            do i=1,nrec
               do j=1,nvar
                  do k=1,nvar
                     quadf(j,k)=quadf(j,k)+
     &                   (y(i,j)-muclus(ss(i),j))*
     &                   (y(i,k)-muclus(ss(i),k))
                  end do
              end do
           end do

           do i=1,nvar
              do j=1,nvar
                 quadf(i,j)=quadf(i,j)+tinv(i,j)
              end do
           end do

           call riwishart(nvar,nu+nrec,quadf,sigmawork,workm1,
     &                    workv1,
     &                    workmh1,workmh2,iflagp)
           do i=1,nvar
              do j=1,nvar
                 sigma(i,j)=quadf(i,j)
                 sigmainv(i,j)=sigmawork(i,j)
              end do
           end do

c           call dblepr("sigma",-1,sigma,nvar*nvar)
         end if

c++++++++++++++++++++++++++++++++++++++++
c+++++++ baseline mean                +++
c++++++++++++++++++++++++++++++++++++++++

         if(sammu.eq.1)then
            do i=1,nvar
               tmp1=0.d0
               do j=1,nvar
                  quadf(i,j)=prec0(i,j)+dble(ncluster)*sigmabinv(i,j)
                  tmp1=tmp1+prec0(i,j)*m0(j)
               end do
               workv1(i)=tmp1
            end do

            call inverse(quadf,nvar,iflagp)

            do ii=1,ncluster

c+++++++++++++ check if the user has requested an interrupt
               call rchkusr()

               do i=1,nvar
                  tmp1=0.d0
                  do j=1,nvar
                     tmp1=tmp1+sigmabinv(i,j)*muclus(ii,j)
                  end do
                  workv1(i)=workv1(i)+tmp1
               end do
            end do

            do i=1,nvar
               tmp1=0.d0
               do j=1,nvar
                  tmp1=tmp1+quadf(i,j)*workv1(j)
               end do
               ywork(i)=tmp1
            end do

            call rmvnorm(nvar,ywork,quadf,workmh1,workv1,mub)

c            call dblepr("mub",-1,mub,nvar)
         end if

c++++++++++++++++++++++++++++++++++++++++
c+++++++ baseline covariance          +++
c++++++++++++++++++++++++++++++++++++++++

         if(samsb.eq.1)then
            do i=1,nvar
               do j=1,nvar
                  quadf(i,j)=0.d0
               end do
            end do

            do i=1,ncluster
               do j=1,nvar
                  do k=1,nvar
                     quadf(j,k)=quadf(j,k)+
     &               (muclus(i,j)-mub(j))*
     &               (muclus(i,k)-mub(k))
                  end do
              end do
            end do

            do i=1,nvar
               do j=1,nvar
                  quadf(i,j)=quadf(i,j)+tbinv(i,j)
               end do
            end do

            call riwishart(nvar,nub+ncluster,quadf,sigmawork,workm1,
     &                  workv1,
     &                  workmh1,workmh2,iflagp)
            do i=1,nvar
               do j=1,nvar
                  sigmab(i,j)=quadf(i,j)
                  sigmabinv(i,j)=sigmawork(i,j)
               end do
            end do

c            call dblepr("sigmab",-1,sigmab,nvar*nvar)
         end if

c++++++++++++++++++++++++++++++++++++++++
c+++++++ precision parameters         +++
c++++++++++++++++++++++++++++++++++++++++

c+++++++ check if the user has requested an interrupt
         call rchkusr()

         do i=1,nstudy+1
            if(a0b0(i,1).gt.0.0)then
               nj=0
               ncj=sccluster(i)
               do j=1,ncj
                  ii=scstrt(i,j)
                  nj=nj+ccluster(ii)
               end do
               if(nj.gt.0)then
                  call samalph(tmp1,a0b0(i,1),a0b0(i,2),ncj,nj)
                else
                  tmp1=rbeta(a0b0(i,1),a0b0(i,2))
               end if
               alpha(i)=tmp1
            end if
         end do

c         call dblepr("alpha",-1,alpha,nstudy+1)

c++++++++++++++++++++++++++++++++++++++++
c+++++++ sampling eps                 +++
c++++++++++++++++++++++++++++++++++++++++
         if(sameps.eq.1)then

            n0=0
            nc0=sccluster(nstudy+1)
            if(nc0.gt.0)then
               do j=1,nc0
                  ii=scstrt(nstudy+1,j)
                  n0=n0+ccluster(ii)
               end do
            end if
            n1=nrec-n0

            tmp1=aebe(1)+dble(n0)
            tmp2=aebe(2)+dble(n1)
            tmp3=aebe(1)
            tmp4=aebe(2)
            tmp5=exp(lbetaf(tmp1,tmp2)-lbetaf(tmp3,tmp4))

            prob(1)=0.d0
            prob(2)=0.d0
            if(n0.eq.nrec)prob(1)=pieps(1)
            if(n1.eq.nrec)prob(2)=pieps(2)
            prob(3)=(1.d0-pieps(1)-pieps(2))*tmp5

            call simdisc(prob,nrec+100,3,evali)

            if(evali.eq.1)then
               eps=0.d0
              else if(evali.eq.2)then
               eps=1.d0
              else
               eps=rbeta(tmp1,tmp2)
            end if

c            call dblepr("eps",-1,eps,1)
         end if

c++++++++++++++++++++++++++++++++++++++++
c+++++++ saving samples               +++
c++++++++++++++++++++++++++++++++++++++++

         if(iscan.gt.nburn)then
            skipcount=skipcount+1
            if(skipcount.gt.nskip)then
               isave=isave+1
               dispcount=dispcount+1

c+++++++++++++ kernel covariance

               ii=0
               do i=1,nvar
                  do j=i,nvar
                     ii=ii+1
                     thetasave(isave,ii)=sigma(i,j)
                  end do
               end do

c+++++++++++++ eps
               ii=ii+1
               thetasave(isave,ii)=eps

c+++++++++++++ precision parameters
               do i=1,nstudy+1
                  ii=ii+1
                  thetasave(isave,ii)=alpha(i)
               end do

c+++++++++++++ baseline means

               do i=1,nvar
                  ii=ii+1
                  thetasave(isave,ii)=mub(i)
               end do

c+++++++++++++ baseline covariance

               do i=1,nvar
                  do j=i,nvar
                     ii=ii+1
                     thetasave(isave,ii)=sigmab(i,j)
                  end do
               end do

c+++++++++++++ density of each component in the mixture

               do i=1,nstudy+1
                  nj=0
                  ncj=sccluster(i)

                  if(ncj.gt.0)then
                     do j=1,ncj
                        ii=scstrt(i,j)
                        nj=nj+ccluster(ii)
                     end do

                     do j=1,ncj
                        ii=scstrt(i,j)
                        prob(j)=dble(ccluster(ii))/(alpha(i)+dble(nj))
                     end do
                  end if
                  prob(ncj+1)=alpha(i)/(alpha(i)+dble(nj))

                  if(ncj.gt.0)then
                     do j=1,ncj
                        ii=scstrt(i,j)
                        kk=0
                        do k=1,nvar
                           tmp1=muclus(ii,k)
                           tmp2=sigma(k,k)
                           do l=1,ngrid
                              kk=kk+1
                            densmc(i,kk)=densmc(i,kk)+
     &                      prob(j)*dnrm(grid(l,k),tmp1,sqrt(tmp2),0)
                           end do
                        end do
                     end do
                  end if

                  kk=0
                  do k=1,nvar
                     tmp1=mub(k)
                     tmp2=sigma(k,k)+sigmab(k,k)
                     do l=1,ngrid
                        kk=kk+1
                        densmc(i,kk)=densmc(i,kk)+
     &                  prob(ncj+1)*dnrm(grid(l,k),tmp1,sqrt(tmp2),0)
                     end do
                  end do
               end do

c+++++++++++++ density for each study

               do i=1,nstudy

                  nj=0
                  ncj=sccluster(i)
                  if(ncj.gt.0)then
                     do j=1,ncj
                        ii=scstrt(i,j)
                        nj=nj+ccluster(ii)
                     end do
                  end if

                  n0=0
                  nc0=sccluster(nstudy+1)
                  if(nc0.gt.0)then
                     do j=1,nc0
                        ii=scstrt(nstudy+1,j)
                        n0=n0+ccluster(ii)
                     end do
                  end if

                  tmp3=0.d0
                  if(ncj.gt.0)then
                     do j=1,ncj
                        ii=scstrt(i,j)
                        prob(j)=(1.d0-eps)*
     &                     dble(ccluster(ii))/(alpha(i)+dble(nj))
                        tmp3=tmp3+prob(j)
                     end do
                  end if

                  if(nc0.gt.0)then
                     do j=1,nc0
                        ii=scstrt(nstudy+1,j)
                        prob(ncj+j)=eps*
     &                    dble(ccluster(ii))/(alpha(nstudy+1)+dble(n0))
                        tmp3=tmp3+prob(ncj+j)
                     end do
                  end if

                  prob(ncj+nc0+1)=(1.d0-eps)*alpha(i)/
     &                            (alpha(i)+dble(nj))
                  tmp3=tmp3+prob(ncj+nc0+1)

                  prob(ncj+nc0+2)=eps*alpha(nstudy+1)/
     &                            (alpha(nstudy+1)+dble(n0))
                  tmp3=tmp3+prob(ncj+nc0+2)

                  if(ncj.gt.0)then
                     do j=1,ncj
                        ii=scstrt(i,j)
                        kk=0
                        do k=1,nvar
                           tmp1=muclus(ii,k)
                           tmp2=sigma(k,k)
                           do l=1,ngrid
                              kk=kk+1
                              densms(i,kk)=densms(i,kk)+
     &                        prob(j)*dnrm(grid(l,k),tmp1,sqrt(tmp2),0)/
     &                        tmp3
                           end do
                        end do
                     end do
                  end if

                  if(nc0.gt.0)then
                     do j=1,nc0
                        ii=scstrt(nstudy+1,j)
                        kk=0
                        do k=1,nvar
                           tmp1=muclus(ii,k)
                           tmp2=sigma(k,k)
                           do l=1,ngrid
                              kk=kk+1
                              densms(i,kk)=densms(i,kk)+
     &                        prob(ncj+j)*
     &                        dnrm(grid(l,k),tmp1,sqrt(tmp2),0)/
     &                        tmp3
                           end do
                        end do
                     end do
                  end if

                  kk=0
                  do k=1,nvar
                     tmp1=mub(k)
                     tmp2=sigma(k,k)+sigmab(k,k)
                     do l=1,ngrid
                        kk=kk+1
                        densms(i,kk)=densms(i,kk)+
     &                  prob(ncj+nc0+1)*
     &                  dnrm(grid(l,k),tmp1,sqrt(tmp2),0)/tmp3
                     end do
                  end do

                  kk=0
                  do k=1,nvar
                     tmp1=mub(k)
                     tmp2=sigma(k,k)+sigmab(k,k)
                     do l=1,ngrid
                        kk=kk+1
                        densms(i,kk)=densms(i,kk)+
     &                  prob(ncj+nc0+2)*
     &                  dnrm(grid(l,k),tmp1,sqrt(tmp2),0)/tmp3
                     end do
                  end do

               end do

c+++++++++++++ print
               skipcount = 0
               if(dispcount.ge.ndisplay)then
                  call cpu_time(sec1)
                  sec00=sec00+(sec1-sec0)
                  sec=sec00
                  sec0=sec1
                  tmp1=sprint(isave,nsave,sec)
                  dispcount=0
               end if
            end if
         end if

      end do

      do i=1,nstudy
         do j=1,ngrid*nvar
            densms(i,j)=densms(i,j)/dble(nsave)
         end do
      end do

      do i=1,nstudy+1
         do j=1,ngrid*nvar
            densmc(i,j)=densmc(i,j)/dble(nsave)
         end do
      end do

      return
      end

c=======================================================================
      subroutine relabelwdpm(ind,since,nrec,nvar,nstudy,
     &                       ncluster,
     &                       ss,cstrt,ccluster,
     &                       sc,muclus)
c=======================================================================
      implicit none
      integer ind,since,nrec,nvar,nstudy,ncluster
      integer ss(nrec)
      integer cstrt(nrec,nrec)
      integer ccluster(nrec)
      integer sc(nrec)
      real*8 muclus(nrec+100,nvar)

      integer i,j,ns,ii,jj,ok

      do i=since+1,ncluster

         ns=ccluster(i)

         do j=1,ns
c++++++++++ check if the user has requested an interrupt
            call rchkusr()
            ii=cstrt(i,j)
            ss(ii)=i-1
         end do

         do j=1,ns
            cstrt(i-1,j)=cstrt(i,j)
         end do

         do j=1,nvar
            muclus(i-1,j)=muclus(i,j)
         end do
         ccluster(i-1)=ccluster(i)

         sc(i-1)=sc(i)
      end do

      ss(ind)=0

      sc(ncluster)=0
      do i=1,nvar
         muclus(ncluster,i)=0.d0
      end do
      ccluster(ncluster)=0
      ncluster=ncluster-1

      return
      end

max_stars_repo_name: kdevick/densitymediation

max_issues_repo_name: kdevick/densitymediation

max_forks_repo_name: kdevick/densitymediation


text:
      MODULE dasum_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.4G  22:48:56  03/08/06
      REAL(KIND(0.0D0)) FUNCTION dasum (N, DX, INCX)
      USE vast_kind_param,ONLY: DOUBLE
      INTEGER, INTENT(IN) :: N, incx
      REAL(DOUBLE), DIMENSION(INCX*N), INTENT(IN) :: DX
      END FUNCTION
      END INTERFACE
      END MODULE

max_stars_repo_name: openmopac/MOPAC-archive

max_issues_repo_name: openmopac/MOPAC-archive

max_forks_repo_name: openmopac/MOPAC-archive


text:
!*******************************************************************************
!>  @file siesta_run.f90
!>  @brief Contains module @ref siesta_run.
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  Defines the base class of the type @ref siesta_run_class. This module
!>  contains all the code necessary to interface setup and run SIESTA.
!*******************************************************************************

      MODULE siesta_run
      USE stel_kinds
      USE shared_data, ONLY: unit_out
      USE timer_mod

      IMPLICIT NONE

!*******************************************************************************
!  siesta run module parameters
!*******************************************************************************
!>  Clear all control bits.
      INTEGER, PARAMETER :: siesta_run_control_clear = 0

!>  Bit position to initalize mpi.
      INTEGER, PARAMETER :: siesta_run_control_mpi = 1
!>  Bit position to close the wout file.
      INTEGER, PARAMETER :: siesta_run_control_wout = 2

!*******************************************************************************
!  DERIVED-TYPE DECLARATIONSf
!  1) siesta_run base class
!
!*******************************************************************************
      TYPE :: siesta_run_class
!>  Timer On
         REAL (dp) :: time_on
!>  Control state.
         INTEGER   :: control_state
      CONTAINS
         PROCEDURE, PASS :: set_vmec => siesta_run_set_vmec
         PROCEDURE, PASS :: set_restart => siesta_run_set_restart
         PROCEDURE, PASS :: set_1d => siesta_run_set_1d
         GENERIC         :: set => set_1d
         PROCEDURE, PASS :: converge => siesta_run_converge
         FINAL           :: siesta_run_destruct
      END TYPE

!*******************************************************************************
!  INTERFACE BLOCKS
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  Interface for the siesta_run constructor.
!-------------------------------------------------------------------------------
      INTERFACE siesta_run_class
         MODULE PROCEDURE siesta_run_construct
      END INTERFACE

      CONTAINS

!*******************************************************************************
!  CONSTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Construct new @ref siesta_run_class object.
!>
!>  Allocates memory and initializes a @ref siesta_run_class object. Performs
!>  all the initialization needed to operate SIESTA.
!>
!>  @param[in] run_comm      MPI Communicator to use.
!>  @param[in] verbose       Control the code screen output.
!>  @param[in] init_mpi      Instructs if MPI should be initialized.
!>  @param[in] close_wout    Instructs if wout file should be closed on
!>                           deallocate.
!>  @param[in] namelist_file Path to the siesta namelist input file.
!>  @returns A pointer to a constructed @ref siesta_run_class object.
!-------------------------------------------------------------------------------
      FUNCTION siesta_run_construct(run_comm, verbose, init_mpi, close_wout,   &
                                    namelist_file)
      USE nscalingtools, ONLY: MyEnvVariables, PARSOLVER, SIESTA_COMM
      USE descriptor_mod, ONLY: LSCALAPACK, INHESSIAN, iam, nprocs,            &
                                nprow, npcol, icontxt, icontxt_1xp,            &
                                icontxt_px1, icontxt_global, isroot,           &
                                myrow, mycol
#if defined(MPI_OPT)
      USE prof_mod, ONLY: profinit
#endif
      USE shared_data, ONLY: nprecon, lverbose
      USE perturbation, ONLY: init_data
      USE hessian, ONLY: HESSPASS
      USE siesta_state, ONLY: lfirst
      USE siesta_error
      USE diagnostics_mod, ONLY: toroidal_flux0
      USE blocktridiagonalsolver_s, ONLY: Initialize, GetRanks
      USE siesta_namelist, ONLY: mpolin, ntorin
      USE metrics, ONLY: set_grid_sizes

      IMPLICIT NONE

!  Declare Arguments
      CLASS (siesta_run_class), POINTER :: siesta_run_construct
      INTEGER, INTENT(in)               :: run_comm
      LOGICAL, INTENT(in)               :: verbose
      LOGICAL, INTENT(in)               :: init_mpi
      LOGICAL, INTENT(in)               :: close_wout
      CHARACTER (len=*), INTENT(in)     :: namelist_file

!  local variables.
      REAL (dp)                         :: ton
      REAL (dp)                         :: toff

!  Start of executable code
      ALLOCATE(siesta_run_construct)

      siesta_run_construct%control_state = siesta_run_control_clear

      IF (init_mpi) THEN
         siesta_run_construct%control_state =                                  &
            IBSET(siesta_run_construct%control_state, siesta_run_control_mpi)
      END IF

      IF (close_wout) THEN
         siesta_run_construct%control_state =                                  &
            IBSET(siesta_run_construct%control_state, siesta_run_control_wout)
      END IF

      CALL siesta_error_clear_all

      lverbose = verbose
      lfirst = .TRUE.
      toroidal_flux0=0

      SIESTA_COMM = run_comm
      HESSPASS = 0
  	  PARSOLVER=.FALSE.

#if defined(MPI_OPT)
      LSCALAPACK = .TRUE.
      INHESSIAN = .FALSE.

      CALL MyEnvVariables
      IF (PARSOLVER) THEN
         LSCALAPACK=.FALSE.
         CALL Initialize(0, 0)        !Must call this to initialize mpi timer
         CALL GetRanks(iam, nprocs)
         CALL sks_timers
      END IF

      IF (LSCALAPACK) THEN
         CALL profinit()

! setup blacs
         CALL blacs_pinfo(iam, nprocs)
         CALL blacs_setup(iam, nprocs)
         DO nprow = INT(SQRT(DBLE(nprocs))) + 1, 1, -1
            npcol = INT( nprocs/nprow )
            IF (nprow*npcol .eq. nprocs) EXIT
         END DO

         CALL blacs_get(0, 0, icontxt)
         CALL blacs_gridinit(icontxt, 'C', nprow, npcol)

         CALL blacs_get(0, 0, icontxt_1xp)
         CALL blacs_gridinit(icontxt_1xp, 'R', 1, nprow*npcol)

         CALL blacs_get(0, 0, icontxt_px1)
         CALL blacs_gridinit(icontxt_px1, 'C', nprow*npcol, 1)

         icontxt_global = icontxt_1xp

         CALL blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
         isroot = (myrow .eq. 0) .and. (mycol .eq. 0)
         IF (isroot .and. lverbose) THEN
            WRITE (*,1000) nprow, npcol
            WRITE (*,1001) icontxt_global, icontxt, icontxt_1xp, icontxt_px1
         END IF
      END IF
#else
      LSCALAPACK = .FALSE.
      iam = 0
      nprocs = 1
#endif

      CALL second0(ton)
      siesta_run_construct%time_on = ton

      nprecon = init_data(namelist_file)
      CALL set_grid_sizes(mpolin, ntorin)

      CALL second0(toff)

      init_data_time = toff - ton

1000  FORMAT('nprow,npcol ',2(x,i5))
1001  FORMAT('icontxt_global,icontxt,icontxt_1xp,icontxt_px1 ',4(x,i5))

      END FUNCTION

!*******************************************************************************
!  DESTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Deconstruct a @ref siesta_run_class object.
!>
!>  Deallocates memory and uninitializes a @ref siesta_run_class object. This
!>  also performs the shut down procedures for SIESTA.
!>
!>  @param[inout] this         A @ref siesta_run_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE siesta_run_destruct(this)
      USE nscalingtools, ONLY: OUTPUT_TIMINGS, GetTimes, PARSOLVER,     &
                               PARFUNCTISL, PARGMRES, SKSDBG, TOFU,     &
                               finalizeremap
      USE blocktridiagonalsolver_s, ONLY: finalize
      USE descriptor_mod, ONLY: iam, icontxt, LSCALAPACK, myrow, mycol, nprocs
      USE shared_data, ONLY: nprecon, xc, gc, fsq_total1, mblk_size,    &
                             niter, col_scale, lverbose, ngmres_type,   &
                             lColScale, gc_sup
      USE hessian, ONLY: levmarq_param, mupar, asym_index, dealloc_hessian
      USE quantities, ONLY: fbdy, dealloc_quantities
      USE dumping_mod, ONLY: write_output
      USE diagnostics_mod, ONLY: write_profiles, dealloc_diagnostics
      USE siesta_namelist, ONLY: wout_file
      USE island_params, ONLY: ns_i
      USE metrics, ONLY: cleanup_metric_elements, dealloc_full_lower_metrics
#if defined(MPI_OPT)
      USE prof_mod, ONLY: profstat
#endif
      IMPLICIT NONE

!  Declare Arguments
      TYPE (siesta_run_class), INTENT(inout) :: this

!  local variables.
      REAL (dp)                              :: ton
      REAL (dp)                              :: toff
      INTEGER                                :: i

!  Start of executable code
      CALL second0(toff)
      time_total = toff - this%time_on

      IF (OUTPUT_TIMINGS) THEN
         CALL GetTimes
      END IF

      IF (iam .EQ. 0) THEN
         DO i = 6, unit_out, unit_out-6
            IF (.NOT.lverbose .AND. i.EQ.6) CYCLE
            WRITE (i, 1000) nprecon, levmarq_param, mupar, asym_index
            WRITE (i,'(a,i5)') ' Number processors: ', nprocs
            WRITE (i, 1001)
            WRITE (i, 1002) time_total,               fbdy(1),          &
                            time_init,                fbdy(2),          &
                            time_diag_prec,           fbdy(3),          &
                            time_block_prec,          fbdy(4),          &
                            time_factor_blocks,       fbdy(5),          &
                            time_toijsp,              fbdy(6),          &
                            time_tomnsp,                                &
                            gmres_time,                                 &
                            conj_grad_time,                             &
                            time_update_pres,         fbdy(7),          &
                            time_update_bfield,       fbdy(8),          &
                            time_current,             fbdy(9),          &
                            get_force_harmonics_time, fbdy(10),         &
                            time_update_force,        fbdy(11),         &
                            time_update_upperv,       fbdy(12),         &
                            time_update_state,        fbdy(13),         &
                            time_funci,                                 &
                            time_apply_precon,                          &
                            (diag_add_pert_time + block_add_pert_time), &
                            time_init_state
            WRITE (i,*)
            IF (PARSOLVER) THEN
               WRITE (i,*)        'PARSOLVER=T    : NSCALED'
            ELSE IF (LSCALAPACK) THEN
               WRITE (i,*)        'PARSOLVER=F    : SCALAPACK'
            ELSE
               WRITE (i,*)        'PARSOLVER=F    : SERIAL'
            END IF
            WRITE (i,*)           'PARFUNCTISL    :', PARFUNCTISL
            WRITE (i,*)           'COLUMN SCALING :', lColScale
            WRITE (i,'(1x,a,L2,a,i2)') 'PARGMRES       :', PARGMRES,    &
                                  ' GMRES_TYPE: ', ngmres_type

            WRITE (i,*)           'OUTPUT_TIMINGS :', OUTPUT_TIMINGS

            WRITE (i,*)
            WRITE (i,101)' TIME DIVB      : ', time_divb
            WRITE (i,101)' TIME DIVJ      : ', time_divj
            WRITE (i,101)' TIME BGRADP    : ', time_bgradp
            WRITE (i,101)' TIME BDOTJ     : ', time_bdotj
            WRITE (i,*)
            WRITE (i,102)' M (block size) :', mblk_size
            WRITE (i,102)' N (block rows) :', ns_i
            WRITE (i,102)' P (processors) :', nprocs
         END DO
      ENDIF
 101  FORMAT(a,1p,e10.3)
 102  FORMAT(a,i5)

      CALL write_output(wout_file, niter,                                      &
                        BTEST(this%control_state, siesta_run_control_wout))
      CALL write_profiles(fsq_total1)  ! SPH: write pmn, bsupXmn, ksubXmn, jvsupXmn profiles
      IF (iam .EQ. 0) THEN
         IF (lverbose) PRINT *,' Writing output to "siesta_profiles.txt" is finished!'
         CLOSE (UNIT=unit_out)
      ENDIF

!CLEAN UP ARRAYS
      CALL cleanup_metric_elements

      CALL dealloc_quantities
      CALL dealloc_hessian
      CALL dealloc_diagnostics
      CALL dealloc_full_lower_metrics
      IF (ALLOCATED(xc)) DEALLOCATE(xc, gc, gc_sup)
      IF (ALLOCATED(col_scale)) DEALLOCATE(col_scale)

#if defined(MPI_OPT)
      IF (LSCALAPACK) THEN
         CALL blacs_barrier(icontxt, 'All')
         CALL blacs_gridexit(icontxt)

         CALL blacs_exit(0)
         IF ((myrow.EQ.0) .AND. (mycol.EQ.0)) THEN
            CALL profstat
         END IF

      ELSE
         IF (SKSDBG) THEN
            WRITE(TOFU,*) 'Called finalizeRemap and Finalize'
            FLUSH(TOFU)
         END IF
         CALL finalizeRemap
         CALL Finalize(BTEST(this%control_state, siesta_run_control_mpi))

      END IF
#endif

1000  FORMAT(/,' nprecon: ',i3,' LM parameter: ',1pe9.2,' mu||: ',1pe9.2,      &
             ' Symmetry Index: ',1pe9.2)
1001  FORMAT(/,'==============================',14x,'=======================', &
             /,                                                                &
             /,' TIMING INFORMATION           ',14x,' RMS BOUNDARY FORCES',    &
             /,                                                                &
             /,'==============================',14x,'=======================')
1002  FORMAT(' Total runtime  : ',  f12.3,15x,'fs(1,m=1)  :',1pe10.2/,         &
             ' Initialization : ',0pf12.3,15x,'fs(2,m=1)  :',1pe10.2/,         &
             ' Diagonal prec  : ',0pf12.3,15x,'fs(2,m!=1) :',1pe10.2/,         &
             ' Compute blocks : ',0pf12.3,15x,'fu(1,m=1)  :',1pe10.2/,         &
             ' Factor blocks  : ',0pf12.3,15x,'fu(2,m=1)  :',1pe10.2/,         &
             ' Toijsp         : ',0pf12.3,15x,'fu(2,m!=1) :',1pe10.2/,         &
             ' Tomnsp         : ',0pf12.3,/,                                   &
             ' GMRES          : ',0pf12.3,/,                                   &
             ' Conj Gradient  : ',0pf12.3,//,                                  &
             ' SUBROUTINES     ',/,                                            &
             ' Update Pressure: ',0pf12.3,15x,'fv(1,m=0)  :',1pe10.2/,         &
             ' Update Bfield  : ',0pf12.3,15x,'fv(2,m=0)  :',1pe10.2/,         &
             ' CV Currents    : ',0pf12.3,15x,'fv(2,m!=0) :',1pe10.2/,         &
             ' Force Harmonics: ',0pf12.3,15x,'fu(ns)     :',1pe10.2/,         &
             ' Update Force   : ',0pf12.3,15x,'fu(ns-1)   :',1pe10.2/,         &
             ' Update UpperV  : ',0pf12.3,15x,'fv(ns)     :',1pe10.2/,         &
             ' Update State   : ',0pf12.3,15x,'fv(ns-1)   :',1pe10.2/,         &
             ' Funct Island   : ',0pf12.3/,                                    &
             ' Apply Precon   : ',0pf12.3/,                                    &
             ' Add Perturb    : ',0pf12.3/,                                    &
             ' Init State     : ',0pf12.3,                                     &
             /,'==============================',14x,'=======================')

      END SUBROUTINE

!*******************************************************************************
!  SETTER SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Sets quanties based on VMEC values.
!>
!>  This method loads and sets variables based on the VMEC equilibrium. VMEC
!>  controls the metric elements and coordinate system jacobian.
!>
!>  @param[inout] this A @ref siesta_run_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE siesta_run_set_vmec(this)
      USE siesta_namelist, ONLY: nsin, mpolin, ntorin, nfpin, wout_file,       &
                                 l_vessel
      USE metrics, ONLY: init_metric_elements, LoadGrid, sqrtg
      USE quantities, ONLY: init_quantities, init_fields
      USE island_params, ns=>ns_i, mpol=>mpol_i, ntor=>ntor_i
      USE shared_data, ONLY: nsp
      USE vmec_info
      USE grid_extension, ONLY: grid_extender, read_vessel_file
      USE pchelms
      USE evolution, ONLY: init_evolution
      USE nscalingtools, ONLY: initRemap

      IMPLICIT NONE

!  Declare Arguments
      CLASS (siesta_run_class), INTENT(inout) :: this

!  local variables
      INTEGER                                 :: istat

!  Start of executable code
      CALL vmec_info_set_wout(wout_file, nsin, mpolin, ntorin, nfpin)

!  CONSTRUCT R, Z, L REAL-SPACE ARRAYS ON SQRT(FLUX) - "POLAR" - MESH AND
!  COMPUTE METRIC ELEMENTS AND JACOBIAN
      CALL LoadGrid(istat)
      CALL assert_eq(0, istat, 'LoadRZL error in siesta_run_set_vmec')

!  If the l_vessel is true try to read a vessel file and extend the grid.
!  Otherwise proceed with fixed boundary equilibrium.
      IF (l_vessel .and. read_vessel_file() .eq. 0) THEN
         CALL grid_extender(wout_file, 'quad', istat)
      ELSE
         l_vessel = .false.
      END IF

      CALL init_metric_elements()
      CALL init_quantities !Initializes BCYCLIC
      CALL init_evolution !neqs is set here
      CALL initRemap(mpol, ntor, ns, nprocs, iam)
      CALL InitHess

      IF (l_vessel) THEN
         CALL run_pchelms
      END IF
      CALL Init_Fields

      DEALLOCATE (sqrtg)

      END SUBROUTINE

!-------------------------------------------------------------------------------
!>  @brief Sets quantities for restarting.
!>
!>  This loads and sets variables from a restarted SIESTA equilibrium. The
!>  restart file constains the metric elements, coordinate system jacobian and
!>  the
!>
!>  @param[inout] this A @ref siesta_run_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE siesta_run_set_restart(this)
      USE restart_mod, ONLY: restart_read
      USE siesta_namelist, ONLY: lrestart, mpolin, ntorin, nsin, restart_ext,  &
                                 wout_file, nfpin, nsin_ext, l_vessel
      USE shared_data, ONLY: nprecon
      USE metrics, ONLY: init_metric_elements
      USE quantities, ONLY: init_quantities
      USE descriptor_mod, ONLY: iam, nprocs
      USE evolution, ONLY: init_evolution
      USE nscalingtools, ONLY: initRemap
      USE island_params, ONLY: ns=>ns_i, hs=>hs_i, ohs=>ohs_i, nsh
      USE hessian, ONLY: InitHess

      IMPLICIT NONE

!  Declare Arguments
      CLASS (siesta_run_class), INTENT(inout) :: this

!  Start of executable code
      IF (l_vessel) THEN
         ns = nsin + nsin_ext
      ELSE
         ns = nsin
      END IF
      nsh = ns - 1
      ohs = nsin - 1
      hs = 1.0/ohs

      nprecon = restart_read(restart_ext, wout_file, mpolin, ntorin, nfpin,    &
                             ns)

      CALL init_metric_elements()
      CALL init_quantities !Initializes BCYCLIC
      CALL init_evolution !neqs is set here
      CALL initRemap(mpolin, ntorin, ns, nprocs, iam)
      CALL InitHess

      END SUBROUTINE

!-------------------------------------------------------------------------------
!>  @brief Set 1D parameter value.
!>
!>  @param[inout] this        @ref siesta_run_class instance.
!>  @param[in]    param_name Name of the parameter to set.
!>  @param[in]    value      Value to set the parameter to.
!>  @param[in]    index      Array index of to set the value to.
!-------------------------------------------------------------------------------
      SUBROUTINE siesta_run_set_1d(this, param_name, value, index)
      USE siesta_namelist, ONLY: helpert
      USE siesta_error

      IMPLICIT NONE

!  Declare Arguments
      CLASS (siesta_run_class), INTENT(inout) :: this
      CHARACTER (len=*), INTENT(in)           :: param_name
      REAL (dp)                               :: value
      INTEGER, INTENT(in)                     :: index

!  Start of executable code.
      SELECT CASE (TRIM(param_name))

         CASE ('helpert')
            helpert(index) = value

         CASE DEFAULT
            CALL siesta_error_set_error(siesta_error_param,                    &
                                        'Warning unknown parameter name ' //   &
                                        TRIM(param_name))

      END SELECT

      END SUBROUTINE

!*******************************************************************************
!  GETTER SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Get 1D parameter value.
!>
!>  @param[inout] this        @ref siesta_run_class instance.
!>  @param[in]    param_name Name of the parameter to set.
!>  @param[in]    index      Array index of to set the value to.
!>  @returns Value of the parameter at the index.
!-------------------------------------------------------------------------------
      FUNCTION siesta_run_get_1d(this, param_name, index)
      USE siesta_namelist, ONLY: helpert

      IMPLICIT NONE

!  Declare Arguments
      REAL (dp)                            :: siesta_run_get_1d
      CLASS (siesta_run_class), INTENT(in) :: this
      CHARACTER (len=*), INTENT(in)        :: param_name
      INTEGER, INTENT(in)                  :: index

!  Start of executable code.
      SELECT CASE (TRIM(param_name))

         CASE ('helpert')
            siesta_run_get_1d = helpert(index)

         CASE DEFAULT
            siesta_run_get_1d = 0.0

      END SELECT

      END FUNCTION

!*******************************************************************************
!  UTILITY SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Solves the SIESTA equilibrium.
!>
!>  This method converges the siesta_run_class equilibrium. Initializes the
!>  evolution module variables and converges the force residual using a diagonal
!>  preconditioner. Applies the external island perturbation if possible. Loads
!>  restart file before convergence.
!>
!>  @param[inout] this A @ref siesta_run_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE siesta_run_converge(this)
      USE evolution, ONLY: converge_diagonal, converge_blocks
      USE descriptor_mod, ONLY: DIAGONALDONE
      USE siesta_namelist, ONLY: ftol, wout_file
      USE utilities, ONLY: test_utilities

      IMPLICIT NONE

!  Declare Arguments
      CLASS (siesta_run_class), INTENT(inout) :: this

!  Local variables
      LOGICAL                                 :: passed

!  Start of executable code
      IF (test_utilities()) THEN
         WRITE (*,*) 'Failed Diverence Test.'
!         STOP
      END IF

!  Converge initial residues with diagonal preconditioner
      DIAGONALDONE = .false.
      CALL converge_diagonal(wout_file, ftol)
      DIAGONALDONE = .true.

!  Converge using block preconditioner
      CALL converge_blocks(wout_file, ftol)

      END SUBROUTINE

      END MODULE

max_stars_repo_name: ORNL-Fusion/SIESTA

max_issues_repo_name: ORNL-Fusion/SIESTA

max_forks_repo_name: ORNL-Fusion/SIESTA


text:
      SUBROUTINE DELTKL (DEL,R,Z,KODE)
C
C     EVAULATE -
C        DELT(K,L) = SURFACE-INTEGRAL((R**K)*(Z**L)) DR*DZ
C        WHERE  DR*DZ IS EITHER A TRIANGLE OR A TRAPEZOID.
C
C     USAGE -
C        CALL  DELTKL (DEL,R,Z,KODE)
C        WHERE  DEL   =  DOUBLE PRECISION ARRAY OF 15 LOCATIONS.
C                        CONTAINING THE RESULTS.
C        WHERE  R     =  DOUBLE PRECISION ARRAY OF  4 LOCATIONS.
C                        CONTAINING THE R-COORDINATES OF THE ELEMENT
C        WHERE  Z     =  DOUBLE PRECISION ARRAY OF  4 LOCATIONS.
C                        CONTAINING THE Z-COORDINATES OF THE ELEMENT
C               KODE  =  0  FOR TRIANGULAR  ELEMENT
C               KODE  =  1  FOR TRAPEZOIDAL ELEMENT
C
C     PROCEDURE -
C        INFORMATION IS COMPUTED AND STORED AS FOLLOWS.
C
C           COMPUTED  FOR        ELEMENT         STORED
C        TRIANGLE   TRAPEZOID    DELT(K,L)      DEL(LOC)
C        ================================================
C           X          X              0,0            1
C           X          X              1,0            2
C           X          X              0,1            3
C           X          X             -1,0            4
C           X          X             -1,1            5
C           X          X             -1,2            6
C                      X              1,1            7
C                      X              1,2            8
C                      X              2,1            9
C                      X              2,0           10
C                      X              0,2           11
C                      X              3,0           12
C                      X              3,1           13
C                      X              3,2           14
C                      X              2,2           15
C
      INTEGER          GOBACK,KODE,N,I,M,L
      DOUBLE PRECISION DEL(15),R(4),Z(4),RM,RI,ZM,ZI,LN,A,B,SI,SM,
     1                 R1,R2,R3,R4,R5,AB,A2,B2,A3,B3,AAB,ABB,R6,R7
C
C     ZERO ARRAY (ONLY THAT PORTION USING)
C
      N = 15
      DO 2 L = 1,N
    2 DEL(L) = 0.0D+0
C
C     HERE FOR LINE 1-2
C
      I = 1
      M = 2
      ASSIGN  23 TO GO BACK
      GO TO 50
C
C     HERE FOR LINE 2-3
C
   23 CONTINUE
      I = 2
      M = 3
      ASSIGN 34 TO GO BACK
      GO TO 50
C
C     HERE FOR LINE 31 (TRIANGLE),  LINE 3-4 (TRAP)
C
   34 CONTINUE
      I = 3
      IF (KODE .GT. 0) GO TO 35
      M = 1
      ASSIGN 90 TO GO BACK
      GO TO 50
   35 M = 4
      ASSIGN 41 TO GO BACK
      GO TO 50
   41 I = 4
      M = 1
      ASSIGN 90 TO GO BACK
C
C     BEGIN LOCAL SUBROUTINE (DEL-KL-I,M)
C
   50 RM = R(M)
      RI = R(I)
      R1 = RM - RI
      IF (DABS(R1) .LT. 1.0D-07) GO TO 80
C
C     THIS LINE IS NOT PARALLEL TO Z-AXIS
C
      ZM = Z(M)
      ZI = Z(I)
      IF (ZI.EQ.0.0D+0 .AND. ZM.EQ.0.0D+0) GO TO 80
C
C     SPECIAL CASE, ZM = ZI = 0   THUS ALL  A,B = 0  AND
C     ALL DEL TERMS  = 0 .   THUS SKIP AND SAVE CPU.
C
      A   = (RM*ZI - RI*ZM)/R1
      B   = (ZM - ZI)/R1
      LN  = DLOG(RM/RI)
      SI  = RI * RI
      SM  = RM * RM
      R2  = SM - SI
      SI  = SI * RI
      SM  = SM * RM
      R3  = SM - SI
      SI  = SI * RI
      SM  = SM * RM
      R4  = SM - SI
      SI  = SI * RI
      SM  = SM * RM
      R5  = SM - SI
      A2  = A  * A
      A3  = A  * A2
      B2  = B  * B
      B3  = B  * B2
      AB  = A  * B
      AAB = A  * AB
      ABB = B  * AB
      DEL( 1) = A*R1 + B*R2/2.0D+0 + DEL(1)
      DEL( 2) = A*R2/  2.0D+0 + B*R3 /3.0D+0 + DEL(2)
      DEL( 3) = A2*R1/ 2.0D+0 + AB*R2/2.0D+0 + B2*R3/6.0D+0 + DEL(3)
      DEL( 4) = A*LN + B*R1   + DEL(4)
      DEL( 5) = A2*LN/ 2.0D+0 + AB*R1  + B2*R2 /4.0D+0 + DEL(5)
      DEL( 6) = A3*LN/ 3.0D+0 + AAB*R1 + ABB*R2/2.0D+0 + B3*R3/9.0D+0
     1        + DEL(6)
      DEL( 7) = A2*R2/ 4.0D+0 + AB*R3/3.0D+0  + B2*R4 /8.0D+0 + DEL(7)
      DEL( 8) = A3*R2/ 6.0D+0 + AAB*R3/3.0D+0 + ABB*R4/4.0D+0
     1        + B3*R5/15.0D+0 + DEL(8)
      DEL( 9) = A2*R3/ 6.0D+0 + AB*R4/4.0D+0 + B2*R5/10.0D+0 + DEL(9)
      DEL(10) = A *R3/ 3.0D+0 + B*R4 /4.0D+0 + DEL(10)
      DEL(12) = A *R4/ 4.0D+0 + B*R5 /5.0D+0 + DEL(12)
      IF (KODE .LT. 1) GO TO 80
      SI      = SI*RI
      SM      = SM*RM
      R6      = SM - SI
      R7      = (SM*RM - SI*RI)
      DEL(11) = A3*R1/ 3.0D+0 + AAB*R2/2.0D+0 + ABB*R3/3.0D+0
     1        + B3*R4/12.0D+0 + DEL(11)
      DEL(13) = A2*R4/ 8.0D+0 + AB*R5 /5.0D+0 + B2*R6/12.0D+0 + DEL(13)
      DEL(14) = A3*R4/12.0D+0 + AAB*R5/5.0D+0 + ABB*R6/6.0D+0
     1        + B3*R7/21.0D+0 + DEL(14)
      DEL(15) = A3*R3/ 9.0D+0 + AAB*R4/4.0D+0 + ABB*R5/5.0D+0
     1        + B3*R6/18.0D+0 + DEL(15)
   80 GO TO GO BACK, (23,34,41,90)
C
C     THE ABSOLUTE VALUE IS CHOSEN SO THAT NODES INPUT MAY BE ORDERED
C     CW OR CCW.   RESULTS ARE SAME FOR A GIVEN ELEMENT.
C
   90 DO 95 L = 1,N
   95 DEL(L) = DABS(DEL(L))
      RETURN
      END

ext: f


program tarefac

    ! variavel que para personalizar o nome dos arquivos de saidas
    character(22) filename
    ! constantes
    parameter (Mmax = 10000000, pi = 4d0*atan(1d0))
    ! vetor AndPos, matrix para receber a coordenada de cada andarilho
    ! vetor I_passo, vetor de direção do passo
    dimension AndPos(Mmax,2), I_passo(2)

    ! recebe o número de passos N
    write(*,*) 'Digite o número de passos N:'
    read(*,*) N

    ! recebe o número de andarilhos M
    write(*,*) 'Digite o número de andarilhos M:'
    read(*,*) M

    ! valor inicial da variavel
    AndPos = 0

    ! loop dos passo
    do j = 1, N

        ! loop dos andarilhos
        do i = 1, M

            ! nrand, parte inteira do rand() dilatado
            nrand = 4*rand()
            ! arg, argumento que fará a rotação do passo no plano (x,y)
            arg = nrand*pi/2
            ! I_passo, recebe o valor do passo como vetor
            I_passo = (/cos(arg), sin(arg)/)
            ! soma o passo para cada andarilho
            AndPos(i,:) = AndPos(i,:) + I_passo

        end do

        ! trecho do código para gerar o arquivo de saida para N = 10**j, se j for inteiro
        exp10 = dlog10(dfloat(j))
        i_exp10 = exp10

        ! condiciona para verificar a hipotese acima
        if (mod(exp10, 1.).eq.0) then

            ! filename é alterada para o expoente correspondente
            write(filename, '(A11,I0,A9)') 'saida-c-10e', i_exp10, '-10407962'
            open(10, file=filename)

            ! loop para gerar o arquivo de saida
            do k = 1, M
                write(10,'(I0,", ",I0)') int(AndPos(k,:))
            end do

            ! r2, soma do r**2
            r2 = (sum(AndPos(:,1)**2) + sum(AndPos(:,2)**2))

            ! r = raiz de r2
            r = sqrt(r2)

            ! calculando delta**2
            delta2 = r2/M - (r/M)**2

            ! escreve no terminal o valor de N, <r> e delta**2
            write(*,'("N: 10e",I0,", <r>: ",1F0.3,", delta**2: ",1F0.3)') i_exp10, abs(r/M), abs(delta2)

            close(10)
        end if

    end do

end program tarefac


text:
c     program DRSNQSOL
c>> 1996-06-21 DRSNQSOL Krogh  Changes for C conversion.
c>> 1994-11-02 DRSNQSOL Krogh  Changes to use M77CON
c>> 1992-04-15 DRSNQSOL CLL.
c>> 1992-01-14 CLL.
c     Demo driver for SNQSOL.  Also using SCKDER.
c     Expected solution vector:  0.9000518     1.0001835     1.0945009
c     ------------------------------------------------------------------
c--S replaces "?": DR?NQSOL, ?NQSOL, ?NRM2, ?CKDER, ?NQFJ
c     ------------------------------------------------------------------
      external R1MACH, SNQFJ, SNRM2
      integer I, IMAX, IOPT(5), J, JMAX, LWA, M, MODE, N, NMAX
      parameter(NMAX = 3, LWA = 3+(15*NMAX+3*NMAX*NMAX)/2 )
      real             R1MACH, SNRM2
      real             FJAC(NMAX,NMAX), FNORM, FVEC(NMAX)
      real             TEST(NMAX,NMAX), TOL, TSTMAX, WA(LWA), X(NMAX)
      data N / NMAX /
c     ------------------------------------------------------------------
      IOPT(4) = 0
      TOL = sqrt(R1MACH(4))
      X(1) = 3.0E0
      X(2) = 3.0E0
      X(3) = 3.0E0
      print*,
     *  'Program DRSNQSOL.  Demo driver for SNQSOL.  Also using SCKDER.'

c     ------------------------------------------------------------------
c               Using SCKDER to check derivative computation.
c     ------------------------------------------------------------------
      print'(/'' Using SCKDER to check derivative computation.'')'
      M  = N
      call SNQFJ(N, X, FVEC ,FJAC, 2)
      MODE = 1
   10 continue
      call SCKDER(MODE, M, N, X, FVEC, FJAC, NMAX, TEST,
     *            IMAX, JMAX, TSTMAX)
      if(MODE .eq. 2) then
         call SNQFJ(N, X, FVEC ,FJAC, 1)
         go to 10
      endif
      call SNQFJ(N, X, FVEC ,FJAC, 1)
      print'(/11x,''X(J) ='',5g11.3:/(17x,5g11.3))',(X(J),J=1,N)
      print'(/1x,''  I    FVEC(I)  '',
     *   '' .....................FJAC(I,J)........................''/)'
      do 20 I = 1,M
         print'(1x,i3,1x,g11.3,1x,5g11.3:/(17x,5g11.3))',
     *         I,FVEC(I),(FJAC(I,J),J=1,N)
   20 continue
      print'(/1x,''TEST(,):''/)'
      do 30 I = 1,M
         print'(1x,i3,13x,5g11.3:/(17x,5g11.3))',I,(TEST(I,J),J=1,N)
   30 continue
      print'(/1x,''IMAX ='',i3,'',    JMAX ='',i3,'',    TSTMAX ='',
     *   g11.3)', IMAX,JMAX,TSTMAX

c     ------------------------------------------------------------------
c           Using SNQSOL to solve system of nonlinear equations.
c     ------------------------------------------------------------------
      print
     *  '(/'' Using SNQSOL to solve system of nonlinear equations.'')'

      call SNQSOL(SNQFJ, N, X, FVEC, TOL, IOPT, WA, LWA)

      FNORM = SNRM2(N,FVEC,1)
c++ CODE for ~.C. is active
      print'('' Termination status:  '',i6/'' NFEV, NJEV:          '',
     * 2i6/ '' Final residual norm: '',g14.3/'' Final X():           ''
     * /(8x,4f14.7))',  IOPT(1), IOPT(2), IOPT(3),
     * FNORM, (X(J), J = 1, N)
c++ CODE for .C. is inactive
c%%   printf( " Termination status:  %6ld\n NFEV, NJEV:          "
c%%   "%6ld%6ld\n Final residual norm: %14.3g\n Final X():           ",
c%%      Iopt[1], Iopt[2], Iopt[3], fnorm);
c%%   for (j = 0; j < n; j+=4){
c%%      printf( "\n        " );
c%%      for (i = j; i < (j < n - 3 ? j + 4 : n); i++)
c%%         printf( "%14.7f", x[i] );}
c%%   printf( "\n" );
c++ END
      stop
      end
c     ==================================================================
      subroutine SNQFJ(N, X, FVEC ,FJAC, IFLAG)
c>> 1992-01-14 CLL.
c     Sample 3-dimensional function of 3 variables for demo of solution
c     of a system of nonlinear equations.
c     ------------------------------------------------------------------
      integer I, IFLAG, N
      real             C1(3), C2(3), C3(3), FJAC(N,N), FVEC(N)
      real             TERM(3), X(N)
      data C1 / -1.0e0,  2.0e0,  2.0e0 /
      data C2 /  2.0e0, -1.0e0,  2.0e0 /
      data C3 /  2.0e0,  2.0e0, -1.0e0 /
      data TERM / 5.01e0, 5.85e0, 8.88e0 /
c     ------------------------------------------------------------------
      if (IFLAG .eq. 1) then
c                                        Compute function vector.
         do 10 I = 1,N
            FVEC(I) = exp(C1(I)*X(1)) + sinh(C2(I)*X(2)) +
     *                tanh(C3(I)*X(3)) - TERM(I)
   10    continue
      elseif (IFLAG .eq. 2) then
c                                        Compute Jacobian matrix.
         do 40 I = 1, N
            FJAC(I,1) = exp(C1(I)*X(1)) * C1(I)
            FJAC(I,2) = cosh(C2(I)*X(2)) * C2(I)
            FJAC(I,3) = (1.0e0/cosh(C3(I)*X(3)))**2 * C3(I)
  40     continue
      endif
      return
      end


text:
! Author: nakinor
! Created: 2016-03-09
! Revised: 2016-03-15

! 月齢を計算して求めるプログラム

! 一行は 132 バイト以内にしないとエラーになる

program getsurei
  implicit none

  integer arr(12)/ 0, 2, 0, 2, 2, 4, 5, 6, 7, 8, 9, 10 /

  character(len=8) date  ! この辺ムダだけど
  character(len=10) time ! この辺ムダだけど
  character(len=5) zone  ! この辺ムダだけど
  integer val(8)         ! 戻り値が 8 つもあるらしい。3 つしか使わんけど
  integer a, b, c, getsu

  call date_and_time(date, time, zone, val)

  a = mod((val(1) - 11), 19) * 11
  b = arr(val(2))
  c = val(3)
  getsu = mod((a + b + c), 30)

  write (*, '(a, i4, a, i0, a, i0, a, i0, a)') &
       "今日は", val(1), "年", val(2), "月", val(3), "日です。月齢は約", &
       getsu, "日です。"

end program getsurei

max_stars_repo_name: uakms/moonphases

max_issues_repo_name: nakinor/moonphases

max_forks_repo_name: nakinor/moonphases


text:
Debats du Senat (hansard)
1ere Session, 36 e Legislature,
Volume 137, Numero 123
Le mardi 23 mars 1999
L'honorable Gildas L. Molgat, President
L'Annee de la Francophonie canadienne
Le championnat de basketball de l'Union sportive interuniversitaire canadienne pour 1999
Felicitations aux Huskies de l'Universite Saint Mary's
La Journee internationale pour l'elimination de la discrimination raciale
La Journee internationale pour l'elimination de la discrimination raciale
Regie interne, budgets et administration
Presentation du trente-deuxieme rapport du comite
La Loi sur les arrangements fiscaux entre le gouvernement federal et les provinces
Projet de loi modificatif-Rapport du comite
Les travaux du Senat
L'Association parlementaire canadienne de l'OTAN
Le cinquantieme anniversaire de l'entree dans la Confederation-Avis d'interpellation
Le cabinet du premier ministre
L'equite en matiere d'emploi au Senat-La position du gouvernement
Reponses differees a des questions orales
Depot de la reponse a une question au Feuilleton
La defense nationale-Le nouveau manege militaire a Shawinigan
L'Office episcopal catholique romain du Mackenzie-Message des Communes
La Loi sur les allocations aux anciens combattants
La Loi sur le ministere des Anciens combattants
La Loi sur le Tribunal des anciens combattants (revision et appel)
Projet de loi modificatif-Rapport du comite
Le programme d'echange de pages avec la Chambre des communes
Projet de loi sur l'Agence des douanes et du revenu du Canada
Troisieme lecture-Ajournement du debat
Projet de loi sur les services publicitaires fournis par des editeurs etrangers
Deuxieme lecture-Suite du debat
Projet de loi de credits no 5 pour 1998-1999
Projet de loi de credits no 1 pour 1999-2000
Deuxieme lecture-Ajournement du debat
Projet de loi sur la gestion des terres des Premieres nations.
Deuxieme lecture-Suite du debat
La Loi concernant l'Association des comptables generaux accredites du Canada-Deuxieme lecture
L'hormone de croissance recombinante bovine
L'etat du systeme financier
La revue des politiques sur les armes nucleaires
Le debat concernant l'envoi de troupes a l'etranger-Interpellation-Suite du debat
Autorisation au comite de sieger en meme temps que le Senat
La reponse du gouvernement aux demandes et recommandations-Interpellation-Suite du debat
La position internationale dans le domaine des communications
Le mardi 23 mars 1999
La seance est ouverte a 14 heures, le President etant au fauteuil.
Son Honneur le President :
Son Honneur le President :
Au nom de tous les senateurs, je vous souhaite la bienvenue au Senat du Canada.
L'Annee de la Francophonie canadienne
L'honorable Jean-Robert Gauthier :
Le championnat de basketball de l'Union sportive interuniversitaire canadienne pour 1999
Felicitations aux Huskies de l'Universite Saint Mary's
L'honorable Wilfred P. Moore :
C'etait la premiere fois que ce titre etait remporte en prolongation.
L'entraineur des Huskies, Ross Quackenbush, faisait partie des equipes de 1978 et 1979.
Nous felicitons sincerement l'entraineur, M. Quackenbush, son equipe et leur legion de partisans.
La Journee internationale pour l'elimination de la discrimination raciale
L'honorable Erminie J. Cohen :
Voila un engagement important qui merite notre attention.
Selon les statistiques, les crimes haineux sont en augmentation depuis ces dernieres annees.
Si c'est le cas, on sacrifie des principes par opportunisme.
Le dernier conscrit de force, evidemment, est Robert Bourassa.
Personne n'est dupe de cette mascarade.
Robert Bourassa n'aurait pas fait cet affront aux francophones du Canada.
La Banque Canadienne Imperiale de Commerce etait la fondatrice et commanditaire du prix.
La Journee internationale pour l'elimination de la discrimination raciale
Ces efforts proactifs et en grande partie preventifs sont salutaires.
L'honorable Mabel M. DeWare :
La nouvelle loi est entree en vigueur en octobre 1996.
Cependant, ce ne sont pas la des formes de discrimination.
Ce sont des mesures cruciales pour parvenir a une egalite veritable.
Son Honneur le President :
Son Honneur le President :
Au nom de tous les senateurs, je vous souhaite la bienvenue au Senat du Canada.
Regie interne, budgets et administration
Presentation du trente-deuxieme rapport du comite
Le mardi 23 mars 1999
Son Honneur le President :
Honorables senateurs, quand etudierons-nous ce rapport?
La Loi sur les arrangements fiscaux entre le gouvernement federal et les provinces
Projet de loi modificatif-Rapport du comite
Le mardi 23 mars 1999
Le comite permanent des finances nationales a l'honneur de presenter son
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une troisieme fois?
Les travaux du Senat
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Son Honneur le President :
Permission accordee, honorables senateurs?
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
L'honorable Noel A. Kinsella (chef adjoint suppleant de l'opposition) :
Pourriez-vous nous donner des explications a ce sujet?
De toute facon, des travaux tres important sont prevus pour demain.
Comme les honorables senateurs peuvent le voir, demain sera une journee tres occupee.
Son Honneur le President :
Plait-il aux honorables senateurs d'adopter la motion?
L'Association parlementaire canadienne de l'OTAN
Le cinquantieme anniversaire de l'entree dans la Confederation-Avis d'interpellation
L'honorable J. Michael Forrestall :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Je l'ai depouille de ses galons.
Ma question a trait a des affaires qui ont deja ete soulevees ici.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Jusqu'a maintenant, je ne suis arrive a rien.
J'ai donc eu tort de ne pas vous aiguillonner a cet egard.
L'honorable B. Alasdair Graham (leader du gouvernement) :
C'est une excellente idee.
Je la transmettrai a mon collegue, le ministre de la Defense nationale.
Le cabinet du premier ministre
L'honorable Erminie J. Cohen :
Je suis persuadee que nous pouvons attendre de ce ministere de splendides resultats concrets.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Je me ferai un plaisir de le faire.
L'honorable Noel A. Kinsella (chef adjoint suppleant de l'opposition) :
Ce sera un plaisir.
Lorsque le texte aura ete traduit, je le deposerai.
Honorables senateurs, je ne crois pas qu'il est question d'un poste ministeriel.
Je pense qu'il s'agit essentiellement d'un role de coordination.
Mme Bradshaw est la personne ideale pour assumer cette tache.
Je ne sais pas.
C'est la prerogative du premier ministre de designer les fonctions de facon officielle.
L'equite en matiere d'emploi au Senat-La position du gouvernement
L'honorable Consiglio Di Nino :
L'honorable B. Alasdair Graham (leader du gouvernement) :
Il fera l'objet d'une discussion en comite dans les meilleurs delais.
Nous prevoyons l'aborder bientot car nous estimons que c'est une question tres importante.
Reponses differees a des questions orales
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
(Reponse a une question posee le 3 mars 1999 par l'honorable Ethel Cochrane)
( Reponse a une question soulevee le 9 mars 1999 par l'honorable Janis Johnson )
Ces trois services publics appartiennent a leur gouvernement provincial respectif.
( Reponse a une question soulevee le 17 fevrier 1999 par l'honorable Donald H. Oliver )
Depot de la reponse a une question au Feuilleton
La defense nationale-Le nouveau manege militaire a Shawinigan
L'Office episcopal catholique romain du Mackenzie-Message des Communes
Projet de loi modificatif-Rapport du comite
Permission ayant ete accordee de revenir aux rapports de comites:
Le mardi 23 mars 1999
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une troisieme fois?
Le programme d'echange de pages avec la Chambre des communes
Son Honneur le President :
Je lui souhaite la bienvenue au Senat.
Projet de loi sur l'Agence des douanes et du revenu du Canada
Troisieme lecture-Ajournement du debat
Mon discours portera sur ces aspects du projet de loi.
Ce n'est pas inhabituel.
Il faut actuellement jusqu'a 12 mois pour doter un poste a Revenu Canada.
La charge de travail de Revenu Canada augmente rapidement.
La demande de services commerciaux augmente de facon significative.
Il n'en est rien.
Les employes beneficieront de tous reglements deja negocies en matiere d'equite salariale.
Revenu Canada veut preserver les droits fondamentaux des employes tout en conservant une flexibilite.
Elles ne sont donc pas visees par les conventions collectives en vigueur.
Il continuera d'en etre ainsi au sein de la nouvelle agence.
Au contraire, ils demeureront membres de la fonction publique federale.
Honorables senateurs, j'espere que vous trouverez ces garanties rassurantes.
Pourtant, cette province n'a actuellement aucun representant a Revenu Canada.
L'honorable Noel A. Kinsella (chef adjoint suppleant de l'opposition) :
Honorables senateurs, puis-je poser une question au senateur Carstairs?
(Sur la motion du senateur Stratton, le debat est ajourne.)
Projet de loi sur les services publicitaires fournis par des editeurs etrangers
Deuxieme lecture-Suite du debat
L'honorable John Lynch-Staunton (chef de l'opposition) :
... d'exemples du genie autochtone.
et que c'etait regrettable:
Les dirigeants de la LNH sont a New York.
La plupart des joueurs etoiles sont des etrangers.
Les salaires sont verses en argent americain.
Le senateur Graham nous a dit:
Je n'ai rien a redire a cela.
Maintenant, le senateur Graham nous assure que:
Elles sont egalement conformes, bien sur, aux obligations du Canada en vertu de l'ALENA.
Le bilan du gouvernement a cet egard est plutot sombre.
Par qui, pourrions-nous demander?
Pourquoi dites-vous cela?
Pensez-vous que la solution reside dans le projet de loi...
Le projet de loi C-55 n'est pas un cas isole.
(Sur la motion du senateur Kinsella, le debat est ajourne.)
Projet de loi de credits no 5 pour 1998-1999
Tout le monde devrait s'en preoccuper.
Malgre ces chiffres, il nous faut reconnaitre qu'il y a des risques de derapage.
Son Honneur le President :
(La motion est adoptee et le projet de loi est lu une deuxieme fois.)
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une troisieme fois?
Projet de loi de credits no 1 pour 1999-2000
Deuxieme lecture-Ajournement du debat
Je suis sure que cela va grandement interesser le senateur Stratton.
(Sur la motion du senateur Stratton, le debat est ajourne.)
Projet de loi sur la gestion des terres des Premieres nations.
Deuxieme lecture-Suite du debat
Dieu sait si nous avons souvent eu tort.
Pourquoi leur refuserions-nous leur chance?
Ce projet de loi presente des difficultes.
Il y a des questions a etudier.
Nous avons parle du projet de loi avec beaucoup de franchise.
Je leur ai fait part de mes preoccupations.
J'aimerais parler des deux aspects du projet de loi qui me preoccupent.
En echange, l'Etat s'engage a lui verser une indemnisation equitable.
Des mesures d'expropriation ne peuvent etre prises a la legere.
La loi federale aussi bien que les lois provinciales contiennent des dispositions en ce sens.
J'en ai vu trois.
Ils ne parlent pas ou presque d'expropriation.
Apres tout, ils se font exproprier leurs terrains.
Je voudrais signaler un aspect interessant du projet de loi.
Cette cause est devant les tribunaux, qui vont trancher a ce sujet.
Honorables senateurs, j'estime qu'un simple amendement suffit.
Cela etablirait toutes les regles et reglements necessaires.
Je recommande que notre comite envisage serieusement de presenter un amendement de cette nature.
Je suis loin d'etre un specialiste de la question.
Je ne connais pas la reponse a cette question.
La question a ete examinee sous bien des angles.
A la page 58 du volume 4, on dit:
Les Indiennes des reserves sont donc gravement defavorisees.
Dans un autre chapitre du meme rapport intitule: Les Indiennes, on ajoute que:
C'est un probleme important.
Honorables senateurs, voila mes suggestions au sujet du projet de loi C-49.
Ce projet de loi comporte toutefois des lacunes et necessite des amendements.
L'honorable Nicholas W. Taylor :
La question des femmes m'inquiete bien plus que celle de l'expropriation.
Je vois le probleme.
J'entends les non-autochtones se plaindre de l'expropriation.
Je suppose que nous devrons examiner de pres le processus d'expropriation.
Ce sera interessant de voir comment nous reglerons cette question.
Je veux maintenant parler des droits individuels.
Les deux cotes du Senat ont examine cet aspect.
Le liberalisme classique, un concept auquel croient nos deux partis, insiste sur l'individu.
Ce n'est pas le cas.
Le moment est peut-etre venu de commencer a penser aux individus.
Quel genre d'economie developperont-elles?
Quel genre de droit de vote aura-t-elle?
Quels seront ses droits en tant qu'actionnaire?
Cet argent sera-t-il investi dans une entreprise appartenant entierement a une bande?
Mais on s'en garde bien.
Et il ne s'agit pas d'un cas isole.
Les gouvernements procedent encore a des expropriations et privent nos autochtones de leurs droits.
La Loi concernant l'Association des comptables generaux accredites du Canada-Deuxieme lecture
Cette annee-la, CGA-Canada comptait 84 membres, tous bases a Montreal.
C'est essentiellement le but du projet de loi S-25.
Honorables senateurs, ce projet de loi fait essentiellement trois choses.
Deuxiemement, le projet de loi prevoit la denomination abregee CGA-Canada.
L'association concoit des programmes de formation pour ses etudiants et ses membres.
Elle regit le code de discipline.
Elle participe a la definition de normes de comptabilite internationales.
Elle fait de la recherche et publie des rapports.
L'honorable Consiglio Di Nino :
Son Honneur le President :
(La motion est adoptee et le projet de loi est lu une deuxieme fois.)
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une troisieme fois?
L'hormone de croissance recombinante bovine
L'honorable Leonard J. Gustafson :
La reaction du public a ete renversante.
Nous avons recu de nombreuses lettres sur la question.
Nous savons tous que le lait est un produit important.
Que se passe-t-il dans le cas present avec la STbr?
J'ai travaille avec le betail toute ma vie.
La STbr souleve beaucoup d'inquietudes.
Je recommande a tous les senateurs de lire ce rapport detaille.
On a surtout recommande de poursuivre des etudes scientifiques sur la STbr.
Il etait question de documents voles, de pressions exercees, de manipulation.
La plupart de ces elements sont abordes dans le rapport.
Il s'est egalement interesse a la facon dont Sante Canada aborde l'homologation.
Je vais vous donner un exemple.
L'Europe ne veut pas du canola canadien parce qu'il est modifie genetiquement.
L'Europe n'achetera pas notre canola.
Encore une fois, nous tenons a remercier les temoins qui ont comparu devant nous.
Le comite a l'intention de convoquer d'autres temoins.
Je remercie les membres du comite du travail qu'ils ont accompli.
Pour terminer, je voudrais lancer quelques fleurs au comite du Senat.
En general, les membres du comite se sont entendus sur les aspects positifs ou negatifs.
L'honorable Nicholas W. Taylor :
Honorables senateurs, je voudrais, si je peux, poser une question au senateur.
Le comite est donc certainement determine a aller au fond des choses.
Premierement, le document rendu public par le comite n'est qu'un rapport provisoire.
Il n'est absolument pas definitif.
Tous ceux qui ont fait des promesses devant le comite devront rendre des comptes.
Les membres du personnel du comite ont travaille de longues heures.
Ces gens sont responsables de la vente des produits laitiers.
Honorables senateurs, la STbr est une substance visant a augmenter la production.
Ce n'est pas un medicament.
Elle n'apporte absolument rien a la societe.
Je ne suis pas refractaire a la biotechnologie ou a la biodiversite.
Cependant, nous n'avons pas besoin de cette hormone au Canada.
C'est le regrette pere du senateur Hays qui l'a fait.
Il a travaille avec les provinces et les producteurs du pays.
J'etais un consommateur de lait a ce moment-la.
J'ignore si j'etais un bon gestionnaire de l'offre a ce moment-la.
Personne ne peut trouver a redire a ce qu'ils font.
Le Quebec est maintenant dans la meme position.
Parce que nous lui offrons un rendement economique pour produire un produit de qualite.
Le comite a egalement recu plus de 1 000 lettres.
Il s'agit de lettres individuelles.
J'ai recu environ 500 lettres.
D'autres membres du comite en ont recu eux aussi.
Chaque annee, aux Etats-Unis seulement, 60 000 personnes meurent du diabete.
Comme je l'ai dit, ces resultats ont suscite de vives inquietudes en Europe.
On parle maintenant du nombre de pays qui ont approuve ce produit.
Combien de ces pays peuvent exporter une pinte de lait?
C'est de l'hypocrisie.
J'ai toujours considere la recherche comme notre produit le plus important.
Nous savons que nos chercheurs ont peur a present.
Qui va les engager?
Une situation dangereuse est actuellement en train d'etre creee.
Le Codex s'entoure du plus grand secret.
Quand ces gens se reunissent-ils?
Ou obtiennent-ils leurs renseignements?
Les membres du comite ne sont pas permanents.
Ils sont plutot nommes avant chaque reunion.
Ce sont des liens sur lesquels notre comite fera davantage enquete.
La situation aux Etats-Unis est tres preoccupante.
Cela ne ressemble pas a une veritable enquete sur les effets sur la sante.
La societe Monsanto a perdu 250 millions de dollars l'annee derniere.
On a effectue des tests pendant 90 jours sur 30 rats.
On a certes accelere le processus.
Il est evident que les interesses n'avaient pas beaucoup de connaissances.
C'est tout simplement incroyable.
Voila pourquoi j'insiste sur le caractere provisoire du rapport.
Le comite aimerait bien avoir acces aux preuves scientifiques de Monsanto.
Son Honneur le President :
Honorable senateur Whelan, votre temps de parole est ecoule.
Permission est-elle accordee au senateur de poursuivre?
Ces critiques fusent parfois tant de l'interieur de cet edifice que de l'exterieur.
Ils en ont vraiment pour leur argent.
Nous avons fait de notre mieux.
Nous n'avons pas fait passer nos interets de parti avant notre devoir.
On n'a que faire de cette hormone.
Rien ne le prouve a l'heure actuelle.
J'ai d'ailleurs bien confiance que cela n'arrivera jamais.
Honorables senateurs, il est vraiment dommage que le senateur Whelan doive prendre sa retraite.
Je suis tout a fait d'accord avec ses propos sur le fonctionnement du comite.
Les agriculteurs parmi vous comprendront ce que je veux dire.
Le mois dernier, la publication britannique London Observer a sollicite nos commentaires.
Cela ne devrait pas se produire.
Ils doivent effectuer une interview avec le senateur Whelan.
En un mot, c'est une question de confiance.
Pourtant, on a suspendu les exigences.
Les evaluateurs des medicaments ont cru que le fabricant avait essaye de les soudoyer.
Nous ne l'avons pas obtenu.
Encore une fois, le maitre mot est confiance.
Nous tenons cela pour acquis, mais les choses ne se passent pas toujours ainsi.
Ce mois-ci, les motifs d'inquietude se sont accrus.
Ce rapport a ete depose.
Je tiens a traiter du sujet sans detour.
Nous voulons entendre toutes les nouvelles constatations avec l'esprit ouvert.
Les senateurs des deux parties jouaient franc-jeu.
Plusieurs d'entre nous avons de l'experience dans le monde de l'agriculture.
J'ai toujours su qu'il ferait la seule chose a faire.
J'espere que le ministre et ses successeurs garderont le cap.
L'honorable Consiglio Di Nino :
Honorables senateurs, ma collegue repondra-t-elle a une question?
Un article porte la-dessus dans le Quorum d'aujourd'hui.
Au cours des deliberations du comite, d'autres personnes ont-elles pretendu la meme chose?
Il faut etre prudent, honorables senateurs.
La facon superficielle avec laquelle cette affaire a ete traitee est vraiment scandaleuse.
Aux Etats-Unis, la Food and Drug Administration s'est trompee dans sa declaration.
Voila ce que le comite compte faire.
Honorables senateurs, je voudrais, moi aussi, poser une question au president du comite.
Il a parle des travaux genetiques qui sont effectues.
Le president du comite etait-il au courant de cela?
(Sur la motion du senateur Milne, le debat est ajourne.)
L'etat du systeme financier
L'honorable Donald H. Oliver :
Cela m'interessait beaucoup.
Qui sont les gens qui administrent les caisses de retraite?
S'acquittent-ils bien de leur travail?
Quels encouragements s'offrent a eux?
Nous devons obtenir certaines donnees rapidement.
Nous ne comprendrons pas cela et nous finirons avec une mauvaise politique.
Je trouve fort interessante toute la question des activites des investisseurs institutionnels.
La realite, c'est que les investisseurs institutionnels intensifient leurs activites au Canada.
Comme le souligne l'OCDE:
L'absence de vote confidentiel est un probleme cle.
Les investisseurs institutionnels ne pratiquent pas de microgestion.
Les investisseurs institutionnels canadiens devraient connaitre plus intimement un nombre plus restreint d'entreprises.
Cette question revient sans cesse.
Il a ajoute qu'en general, il y a peu de conseils bien diriges.
Son Honneur le President :
Demandez-vous la permission de poursuivre?
Son Honneur le President :
Je vous remercie, honorables senateurs.
Je poursuis ma citation des paroles de John Palmer:
A notre connaissance, la plupart des regimes sont bien geres et bien capitalises.
Toutefois, il conviendrait d'ameliorer les methodes de gestion ou la capitalisation de certains regimes.
Les fonds de pensions posent un probleme particulier a ce niveau.
Dans le monde des entreprises, les actionnaires elisent des administrateurs pour proteger leurs interets.
Les actionnaires ont un important controle sur leur destin.
Le professeur Jeffery Macintosh, de l'Universite de Toronto, a dit dans son temoignage:
John Por a dit, dans son temoignage:
Le comite etait passablement inquiet face a ce risque.
Tous ces domaines exigent un degre eleve de competence et de connaissance.
L'honorable Nicholas W. Taylor :
Honorables senateurs, puis-je poser une question a l'honorable senateur?
Il s'agit d'une question interessante qu'ont soulevee de nombreux temoins.
Nous voterons contre si vous les proposez a la reunion.
Ils leur disent: Nous voulons vous rencontrer.
Les renseignements qu'ils obtiennent alors sont des informations d'inities.
Son Honneur le President :
Honorables senateurs, le senateur Meighen aimerait prendre la parole a ce sujet demain.
Avec votre permission, j'aimerais ajourner le debat au nom du senateur Meighen.
Son Honneur le President :
(Sur la motion du senateur Olivier, au nom du senateur Meighen, le debat est ajourne.)
La revue des politiques sur les armes nucleaires
Ce n'est pas l'objectif vise par la motion.
Qui sait combien de temps elle pourrait prendre?
C'est la l'enjeu.
L'honorable Jerahmiel S. Grafstein :
Honorables senateurs, a prime abord, la promesse de cette solution est au moins louable.
L'expansion de l'OTAN aurait inverse le resultat, d'apres le general Butler.
Que faisons-nous maintenant?
Certains partisans de cette resolution ont peut-etre en tete des objectifs differents des miens.
Quel genre de debat cela peut-il etre, alors?
En quoi le Senat devrait-il renseigner le gouvernement sur l'OTAN?
Bref, quelle devrait etre la position du Canada?
Apres la crise des missiles cubains de 1962, Robert Kennedy a pose la question suivante:
Cela evoque la question fondamentale de la politique etrangere.
Devrait-on evaluer et jauger les Etats en fonction de principes de moralite personnelle?
Pourtant, Niebuhr poursuit en expliquant que les Etats ne peuvent etre sacrifies.
Les gouvernements n'ont pas la latitude dont disposent les individus.
Par necessite, ils sont des mandataires et non pas des mandants.
Niebuhr a cite l'argument de Hugh Cecil.
Le devoir d'autopreservation vient en contradiction avec le devoir personnel de sacrifice.
Il en resulte de la confusion plutot de la clarte.
Bref, les interets nationaux ne peuvent se substituer entierement a la moralite internationale.
Le maitre mot, ici, c'est dissuasion.
Dans un ouvrage recent publie sous la direction de Richard Falkenrath, America's Achilles' Heel:
... des acteurs autres que des Etats qui seraient exceptionnellement aptes.
Ce sont la des questions essentielles qui exigent une reflexion et des etudes critiques.
Ce sont la des risques nouveaux, complexes et fuyants.
Quand est-on justifie de deployer de telles armes?
Salus populi, suprema lex est .
Cela entraine toutefois une autre question fondamentale.
Pourtant, le Canada fait partie de l'armada internationale, au sol et dans les airs.
Il ne faudrait pas confondre similarite de vues et consensus.
Honorables senateurs, je propose l'ajournement du debat.
L'honorable Marcel Prud'homme :
Il pourrait y avoir un accord entre tous les senateurs.
Le Senat pourrait se prononcer.
J'ai beaucoup hesite a parler sur cette motion.
J'ai etudie ce sujet au comite des affaires exterieures et de la defense nationale.
La reunion aura lieu en avril de cette annee.
Je vais prendre un risque calcule.
C'est un risque calcule.
Je ne lirai pas mon discours en faveur de cette motion.
Je demande que l'on appuie cette resolution avant 18 heures.
Nous avons un programme charge.
Nous n'avons pas accompli grand-chose aujourd'hui.
Il semble que ce soit d'accord.
Je prends le risque.
J'appuie cette motion.
Inutile de s'agiter, il s'agit seulement d'une motion.
Cela ne veut pas dire que nous voulons transformer l'OTAN.
Nous ne voulons pas completement transformer l'OTAN.
Son Honneur le President :
(Sur la motion du senateur Spivak, le debat est ajourne avec dissidence.)
Son Honneur le President :
Aucun article n'est a l'ordre du jour presentement.
Honorables senateurs, le Reglement dit que l'on doit ajourner a l8 heures.
Le senateur Carstairs suggere de prolonger le debat.
Cette motion peut etre debattue.
Un article de l'ordre du jour a ete appele.
Son Honneur le President :
Non, c'est inexact.
A 18 heures, je n'ai pas le choix.
Il est maintenant 18 heures.
Le debat concernant l'envoi de troupes a l'etranger-Interpellation-Suite du debat
L'honorable Noel A. Kinsella (chef adjoint suppleant de l'opposition) :
Aux termes de ce meme modele traditionnel, les Serbes se trouvent dans la meme position.
Cela rendrait le combat actuel moins irreconciliable.
(Sur la motion du senateur Carstairs, le debat est ajourne.)
Autorisation au comite de sieger en meme temps que le Senat
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Son Honneur le President :
Est-ce d'accord, honorables senateurs?
La reponse du gouvernement aux demandes et recommandations-Interpellation-Suite du debat
L'honorable Marcel Prud'homme, c.p .).
L'honorable Marcel Prud'homme :
Certains senateurs ne semblent pas comprendre les regles.
Plus tot, j'ai laisse faire.
Cette fois, je peux intervenir.
Mon discours est pret.
Son Honneur le President :
Il a entame le debat et il le poursuivra.
Est-ce d'accord, honorables senateurs?
(Sur la motion du senateur Prud'homme, le debat est ajourne.)
L'honorable senateur Lois M. Wilson , ayant donne avisle 16 mars 1999:
Qu'elle attirera l'attention du Senat sur la situation au Soudan .
Est-ce parce qu'il s'agit d'un pays africain?
La realite est beaucoup plus ambigue.
Le nombre de victimes est horrible, mais largement inconnu.
Selon d'autres sources, le nombre de deces serait encore plus eleve.
La famine et la sous-alimentation sont utilisees comme des armes de guerre strategiques.
Les corridors servant a l'acheminement de l'aide humanitaire sont constamment fermes.
Combien de temps encore sont-ils prets a fournir cette aide?
La nourriture sert comme arme dans ce conflit.
Le probleme en est un de mise en oeuvre.
Le soutien serait assure par un petit groupe de preposes devoues.
Le temps revet une importance primordiale.
Un certain nombre de questions preoccupent le Canada.
Il y a ensuite la necessite de retablir la confiance entre les parties en guerre.
Le mediateur doit envisager des mesures pour retablir la confiance.
Il s'agit de la presence d'une entreprise canadienne au Soudan.
L'image du Canada est desormais une source de preoccupation.
Comment la richesse sera-t-elle repartie, si toutefois elle l'est?
Le petrole commencera a couler en juin.
Cela veut-il dire que la partie sera terminee?
(Sur la motion du senateur Prud'homme, le debat est ajourne.)
Que le comite soit autorise a sieger pendant les seances et les conges du Senat;
Que le comite depose son rapport final au plus tardle 29 octobre 1999.
Cela debordait du cadre normal des responsabilites de l'OTAN telles que definies en 1949.
Cette fois-ci, l'histoire ne se repetera peut-etre pas.
Nous sommes loin de Suez, de Chypre et des hauteurs du Golan.
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
L'honorable Marcel Prud'homme :
J'aimerais poser une question au senateur Lynch-Staunton.
Quelles questions devraient avoir la priorite?
Je penche beaucoup pour cette question.
J'ai des doutes quant a l'expansion de l'OTAN.
Son Honneur le President :
Honorables senateurs, le senateur Lynch-Staunton a-t-il la permission de repondre?
Le senateur Lynch-Staunton a-t-il la permission de repondre?
L'honorable J. Michael Forrestall :
Alliez-vous passer a la motion d'ajournement, senateur Carstairs?
Dans ce cas, puis-je dire quelques jours?
Je tiens a offrir mon appui a la motion du senateur Lynch-Staunton.
A mon avis, nous avons l'occasion d'examiner cette question d'un oeil critique.
Ce plan a ete realise avec une force permanente reguliere d'environ 60 000 membres.
La marine canadienne attend toujours un nouvel helicoptere.
On a aussi cree trois bataillons d'infanterie legere d'environ 3 000 soldats.
Il faudrait peut-etre reorganiser notre armee en fonction de ces operations.
Ceux qui ne connaissent pas assez le passe sont condamnes a le repeter.
C'est pourquoi j'appuie cette motion qui tombe a point nomme.
Au Senat, nous avons un comite des affaires etrangeres.
Nous avons juge que la repartition des efforts et des responsabilites laissait a desirer.
Cela peut se produire sans trop d'ingerence.
Oui, je souhaiterais que nous ayons notre propre comite.
Cependant, je suis tres heureux avec le senateur Stewart.
L'honorable Nicholas W. Taylor :
Le senateur Kinsella a presente d'excellentes idees, a l'instar du senateur Forrestall.
Je participais a une etude geologique commandee par le marechal Tito.
La Slovenie etait la plus riche.
On considerait que le marechal Tito etait un revisionniste.
J'ignore ce que nous pourrions faire en tant que senateurs ou simples citoyens canadiens.
Cependant, je crois que l'attaque est la chose a ne pas faire.
Son intervention devrait etre publiee dans tous les journaux du Canada.
S'il y a des bombardements, nous pouvons etre certains que des innocents souffriront.
Son Honneur le President :
Si aucun autre honorable senateur ne veut la parole, je mettrai la motion aux voix.
Plait-il aux honorables senateurs d'adopter la motion?
La position internationale dans le domaine des communications
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Honorables senateurs, je voudrais poser une question a la presidente du comite.
Prevoit-on que la prolongation sera couteuse?
Son Honneur le President :
Plait-il aux honorables senateurs d'adopter la motion?
(Le Senat s'ajourne au mercredi 24 mars 1999, a 13 h 30.)