text:
c********12/6/95  having trouble getting code to recognize N2, CH4 etc as colliders,
c                 but works with AR and HE--suspect problem might be the routine
c                 'upcase' in "COLL' section--will comment out and observe effect
c***GETPARAMS*************************
      subroutine getparams(linput,lecho,dE)

      implicit none
      include 'cdparams.fh'
      include 'cdwell0.fh'
      include 'cdwell1.fh'
      include 'cdwell2.fh'
      include 'cdisprop.fh'
      include 'cdcolls.fh'
      include 'cdlabels.fh'
      include 'cdrange.fh'
      include 'cdffit.fh'
      include 'cdcontrl.fh'
	include 'cdcheb.fh' ! added by pey 4/6/04

c dmm 20000224
      include 'cdgamma.fh'
c dmm 20000224
c dmm 20000330
      include 'straightBS.fh'
      include 'cdnos.fh'
c dmm 20000330

c    local variables
      real*8 degendef(mxfreqs),freqdef(mxfreqs),sigdef,ekdef,xtot,dE
      integer iWell,jWell,ioWell,ifrq,it,ip,icoll, iTS, isp
      integer linput,lecho,numRC,nfdef
	real*8 deltat, deltap
      character instr*50,cmdstr*20,Wname*15, fname*15
      logical readin,readma,readdf,readdc,tpcorr,fillp,noinfo
      logical readfr(mxWells),readcp(mxWells), trange, prange

	real*8 pi
	parameter (pi = 3.14159265)
c    end declarations

c    these variables are for checking input
      numRC = 0
      readin = .false.
      readma = .false.
      readdf = .false.
      readdc = .false.
      fillp = .false.

c    controls reassignment
      do 10 iWell = 1,mxWells
         readcp(iWell) = .false.
         readfr(iWell) = .false.
10    continue

c    defaults
      fitrange = .false.
      fitglobal = .false.
      showline = .false.
      tpcorr = .false.
      chemact = .false.
      dissoc = .false.
      inpwonly = .false.
      isomers = .false.
      rkold = .false.
      table = .true.
      caseStr = ' '
      Fopt = 'default'
      dE = 1.d0
      nRot = 1
c dmm 20000331
      gammaspec = .false.
      bsgs = 10.0
c dmm 20000331
c tal 20000620-20000822
      oldrho = .false.
      ASA = .false.
      ASActrl = .false.
      noASAstepout = .false.
      nosumisom = .false.
      absrmin = .false.
c tal 20000822
c dmm 20010612 Barker file output
      barker = .false.
c dmm 20010612
      steady = .false.
c dmm 20010813
      dEdcm = .false.
c dmm 20011019
      RRKM = .false.
c dmm 20020314
      XMG = .false.
c pey 29/3/04
	inclks = .false.
	cheby  = .false.
	trange = .false.
	prange = .false.

c    we only zero out variables as are completely necessary
      ncolls = 0
      nWells = 0
      xtot = 0.d0
      do 50 iWell = 1,mxWells
         nfreqs(iWell) = 0
         nProds(iWell) = 0
         idpWell(iWell) = 0
         do 45 ioWell = 1,mxWells
            Aisom(iWell,ioWell) = 0.0d0
            Eisom(iWell,ioWell) = 0.0d0
            rNisom(iWell,ioWell) = 0.0d0
            alphaIsom(iWell,ioWell) = 0.0d0
45       continue
50    continue

c1   loop for reading 1st level commands

c    main entry point
100   continue
         read(linput,'(a)',end=450) instr
         call ljust(instr)
         cmdstr = instr
         call upcase(cmdstr)

c    entry point for inner loops terminated on unknown command
110   continue

c       comment or blank: do nothing
         if ((cmdstr(1:1).eq.'#').or.(cmdstr(1:1).eq.' ')) then
            goto 100

c       get casestr (tag)
         else if (cmdstr(1:3).eq.'TAG') then
         read(linput,'(a)') instr
         call ljust(instr)
         caseStr = instr

c     tal 20000620
c       use old density of states instead of fast
         else if (cmdstr(1:3).eq.'OLD') then
            oldrho = .true.
c     tal 20000620

c     tal 20000627
c       activates ASA algorithm
         else if (cmdstr(1:3).eq.'ASA') then
            ASA = .true.
            ASActrl = .true.
c     tal 20000705
c       allows specification of rmin by using ASA RMIN keywords
            call rjust(cmdstr)
            rminmult = -1.d0
c               write(*,*) cmdstr(len(cmdstr)-6:len(cmdstr))
            if (cmdstr(len(cmdstr)-3:len(cmdstr)) .eq. 'RMIN') then
               read(linput,*,err=999) rminmult
c     tal 20000822
c        allows specification of absolute RMIN
c        (units differ between chemact and dissoc!!!)
            else if (cmdstr(len(cmdstr)-6:len(cmdstr)).eq.'RMINABS')then
               absrmin = .true.
               read(linput,*,err=999) rminmult
c     tal 20000822
            else
               rminmult = 0.01
            end if
c     tal 20000705
c     tal 20000627

c     tal 20000705
c        allows turning off of step output files for ASA.
         else if (cmdstr(1:6) .eq. 'NOSTEP') then
            if (.not. ASA) goto 999
            noASAstepout = .true.
c     tal 20000705

c     dmm 20010612
c     if 'BARKER' keyword used, turn on printing of *.rke, *.dens and
c     TSkey.dat files for Barker MEQ code  input.  Note this requires
c     barker.inp file.

         else if (cmdstr(1:6) .eq. 'BARKER') then
            barker = .true.
c     dmm 20010612

c----------------------------------------------------------------------c
c *** RRKM 1 k(E) Thread *** START                                     c
c----------------------------------------------------------------------c
c     dmm 20011019 RRKM option:  allows substitution of one isom rate
c     constant as an RRKM rate constant (hack job, for H + cycloalkenes
c     test).

         else if (cmdstr(1:4).eq. 'RRKM') then
            RRKM = .true.
            read(linput,*,err=999) i1RRKM, i2RRKM, idgRRKM
c----------------------------------------------------------------------c
c *** RRKM 1 k(E) Thread *** END                                       c
c----------------------------------------------------------------------c

c     dmm 20010702
         else if (cmdstr(1:6).eq.'STEADY') then
            steady = .true.
c     dmm 20010702

c     dmm 20020314
         else if (cmdstr(1:3).eq.'XMG') then
            XMG = .true.

c     dmm 20010813
c     These lines cause CHEMDIS to read the collisional energy transfer
c     energy as deltaEdown, in cm-1, rather than deltaEall in cal/mol

         else if (cmdstr(1:6).eq.'DEDOWN') then
            dedcm = .true.

c     tal 20000814
c         allows choice of RMIN criteria for CHEMACT
c         default: sum of isomer fluxes < RMIN
c         nosumisom: all unique fluxes < RMIN
         else if (cmdstr(1:9) .eq. 'NOSUMISOM') then
            if (.not. ASA)  goto 999
            nosumisom = .true.
c     tal 20000814

c       chemact
         else if (cmdstr(1:4).eq.'CHEM') then
            chemact = .true.

c       dissoc
         else if (cmdstr(1:4).eq.'DISS') then
            dissoc = .true.

c     dmm 20000510
c     dissociation on just one input well (avoid cycling through wells)
c     inpWspec holds well number for dissoc calculation
c     tal 20000705 inpWspec now holds well identifier (species name)
         else if (cmdstr(1:8).eq.'INPWONLY') then
            inpwonly = .true.
            read(linput,'(a)',err=999) inpWspec
            call ljust(inpWspec)
            call upcase(inpWspec)
c     dmm 20000510

c       fitglobal
         else if (cmdstr(1:4).eq.'FITG') then
            fitglobal = .true.

c       surpress rate table output
         else if (cmdstr(1:5).eq.'NOTAB') then
            table = .false.

c	  write only k's included in the pdep network to chemdis-xmg.out (pey 29/3/04)
c	  only has an effect when printing k's at multiple values of T,P
	  else if (cmdstr(1:6).eq.'INCLKS') then
		  inclks = .true.

c	  fit k(T,P) to a Chebyshev polynomial (pey 4/6/04)
	  else if (cmdstr(1:9).eq.'CHEBYSHEV') then
		  read(linput,*,err=999) nchebT, nchebP
		  if (nchebT.gt.mxChebT) then
		     write(lecho,'(A)') 'Max chebyshev order in T exceeded!'
			 stop
	      elseif (nchebP.gt.mxChebP) then
	         write(lecho,'(A)') 'Max chebyshev order in P exceeded!'
		     stop
		  endif
	      cheby = .true.

c       change default fit option
         else if (cmdstr(1:4).eq.'TROE') then
            Fopt = 'Troe'

c       change default fit option
         else if (cmdstr(1:3).eq.'SRI') then
            Fopt = 'SRI'

c       show lineshape parameters (don't invoke unless full p range)
         else if (cmdstr(1:4).eq.'SHOW') then
            showline = .true.

c       use original calculation method for stabilization
         else if (cmdstr(1:3).eq.'RKO') then
            rkold = .true.

c       fitrange
         else if (cmdstr(1:4).eq.'FITR') then
            fitrange = .true.

c       norot - supress 1 active rotation
         else if (cmdstr(1:3).eq.'NOR') then
            nRot = 0

c       change default integration interval (kcal)
         else if (cmdstr(1:3).eq.'INT') then
            read(linput,*,err=999) dE

         else if (cmdstr(1:5).eq.'BSGS') then
            read(linput,*,err=999) bsgs
c       input rate constant
         else if (cmdstr(1:5).eq.'INPUT') then
            read(linput,*,err=999) Ain,rNin,alphaIn,Ein
            readin = .true.

c       mass for all isomers
         else if (cmdstr(1:4).eq.'MASS') then
            read(linput,*,err=999) rmass
            readma = .true.

c       temperature values
         else if (cmdstr(1:4).eq.'TEMP') then
            read(linput,*,err=999) ntemps,(temp(it),
     2         it = 1,min(ntemps,mxtpts))

            if (ntemps.gt.mxtpts) then
               write(lecho,120) mxtpts
120            format(/,' ERROR: max # of ',i2,' temperatures ',
     2            'exceeded.')
               stop
            endif

c	   accept temperature input in form: Tmin, Tmax, nT  (PEY 29/3/04)
		else if(cmdstr(1:6).eq.'TRANGE') then
			read(linput,*,err=999) tmin, tmax, ntemps

			if (ntemps.gt.mxtpts) then
				write(lecho,120) mxtpts
				stop
			endif
		    trange = .true. ! fill temp array below

c       pressure values
         else if(cmdstr(1:4).eq.'PRES') then
            read(linput,*,err=999) npres,(pres(1,ip),
     2         ip = 1,min(npres,mxPpts))

            if (npres.gt.mxPpts) then
               write(lecho,125) mxPpts
125            format(/,' ERROR: max # of ',i2,' pressures ',
     2            'exceeded.')
               stop
            endif
            fillp = .true.
c          later we must fill out entire p array

c	   accept pressure input in the form: Pmin, Pmax, nP (PEY 29/3/04)
		else if(cmdstr(1:6).eq.'PRANGE') then
			read(linput,*,err=999) pmin, pmax, npres

			if (npres.gt.mxPpts) then
				write(lecho,125) mxPpts
				stop
			endif
		    prange = .true. ! fill pres array below
			fillp = .true.

c        correlated t,p option
         else if (cmdstr(1:4).eq.'CORR') then
            read(linput,*,err=999) ntemps,npres
            if (ntemps.gt.mxtpts) then
               write(lecho,120) mxtpts
               stop
            endif
            if (npres.gt.mxPpts) then
               write(lecho,125) mxPpts
               stop
            endif
            do 130 it = 1,ntemps
               read(linput,*,err=999) temp(it),(pres(it,ip),ip=1,npres)
130         continue

c       default freq parameters
         else if (cmdstr(1:4).eq.'FREQ') then
            read(linput,*,err=999) nfdef, (freqdef(ifrq),degendef(ifrq),
     2         ifrq = 1,min(nfdef,mxfreqs))

            if (nfdef.gt.mxfreqs) then
               write(lecho,145) mxfreqs
145            format(/,' ERROR: max # of ',i2,' ind. frequencies ',
     2            'exceeded.')
               stop
            endif
            readdf=.true.

c       default collision parameters
         else if (cmdstr(1:5).eq.'PARAM') then
            read(linput,*,err=999) sigdef,ekdef
            readdc = .true.

c       option for colliders
         else if (cmdstr(1:4).eq.'COLL') then
            ncolls = ncolls+1
            if (ncolls.le.mxcolls) then
               read(linput,'(a)') instr
               call ljust(instr)
               collNM(ncolls) = instr
c********12/6/95   comment out next line
c               call upcase(collNM(ncolls))
               if (collNM(ncolls)(1:1).eq.'!') then
                  read(linput,*,err=999) xcoll(ncolls),rmass2(ncolls),
     2               sig2(ncolls),ek2(ncolls),deltaE(ncolls)
               else
                  read(linput,*,err=999) xcoll(ncolls)
                  call lookup(collNM(ncolls),rmass2(ncolls),
     2               sig2(ncolls),ek2(ncolls),deltaE(ncolls),noinfo)
                  if (noinfo) then
                     write(lecho,580) collNM(ncolls)
580                  format(/,' ERROR: No info on COLLIDER: ',a)
                     stop
                  endif
               endif

               xtot = xtot + xcoll(ncolls)
            else
               write(lecho,140) mxcolls
140            format(/,' ERROR: max # of ',i2,' colliders ',
     2            'exceeded.')
               stop
            endif

c          set default options
            consbeta(ncolls) = .false.
            dEExp(ncolls) = 0.d0

c          checks if beta or exponent specified;
c          if not, return to main loop with command string loaded

            read(linput,'(a)',end=450) instr
            call ljust(instr)
            cmdstr = instr
            call upcase(cmdstr)

c          beta option
            if (cmdstr(1:4).eq.'BETA') then
               read(linput,*,err=999) beta(ncolls)
               consbeta(ncolls) = .true.

c          exponent option
            elseif (cmdstr(1:3).eq.'EXP') then
               read(linput,*,err=999) dEExp(ncolls)

            else
               goto 110
            endif

c       get Well name, parameters
         else if (cmdstr(1:4).eq.'WELL') then
            read(linput,'(a)') instr
            call ljust(instr)
            Wname = instr
            call upcase(Wname)

c          check to see if iWell aready asigned for this isom; if not
c          increase nWells
            iWell = 0
            if (nWells.gt.0) then
c for debugging ...
c               write(*,*) Wname
               do 150 jWell=1,nWells
                  if (Wname.eq.ISname(jWell)) then
                     iWell = jWell
c                     write(*,*) ISname(jWell), iWell, jWell
                  endif
150             continue
            endif
            if (iWell.eq.0) then
               nWells = nWells+1
               iWell = nWells
               if (nWells.gt.mxWells) then
c                  write(*,*) "xxx"
                  write(lecho,160) mxWells
160               format(/,' ERROR:  max # of Wells of ',i3,
     $               ' exceeded.')
                  pause
               endif
               ISname(iWell) = Wname
            endif

c          we now have iWell
            PDname(iWell,0) = ISname(iWell)

c          entry point for Well loop
200         continue
               read(linput,'(a)',end=450) instr
               call ljust(instr)
               cmdstr = instr
               call upcase(cmdstr)

c             comment or blank: do nothing
               if ((cmdstr(1:1).eq.'#').or.(cmdstr(1:1).eq.' ')) then
                  goto 200

c             get reactant channel name, rate
               else if (cmdstr(1:4).eq.'REAC') then
                  numRC = numRC+1
                  inpWell = iWell
                  nProds(iWell)=nProds(iWell)+1
                  if (nProds(iWell).gt.mxProds) then
                     write(lecho,260) mxProds,ISname(iWell)
cjmg fix
c260                  format(/,' ERROR:  max # of Products for one',
c     2                  ' Well of ',i2,' exceeded on ',a'.')
260                  format(/,' ERROR:  max # of Products for one',
     2                  ' Well of ',i2,' exceeded on ',a,'.')
                     stop
                  endif
                  inpchan = nProds(iWell)
                  read(linput,'(a)') instr
                  call ljust(instr)
                  PDname(iWell,nProds(iWell)) = instr
                  call upcase(PDname(iWell,nProds(iWell)))
                  read(linput,*,err=999) AProd(iWell,nProds(iWell)),
     2               rNProd(iWell,nProds(iWell)),
     3               alphaProd(iWell,nProds(iWell)),
     4               EProd(iWell,nProds(iWell))

c             get Product channel name, rate
               else if (cmdstr(1:4).eq.'PROD') then
                  nProds(iWell)=nProds(iWell)+1
                  if (nProds(iWell).gt.mxProds) then
                     write(lecho,260) mxProds,ISname(iWell)
                     stop
                  endif
                  read(linput,'(a)') instr
                  call ljust(instr)
                  PDname(iWell,nProds(iWell)) = instr
                  call upcase(PDname(iWell,nProds(iWell)))
                  read(linput,*,err=999) AProd(iWell,nProds(iWell)),
     2               rNProd(iWell,nProds(iWell)),
     3               alphaProd(iWell,nProds(iWell)),
     4               EProd(iWell,nProds(iWell))

c             get isomerization channel name, rate
               else if (cmdstr(1:4).eq.'ISOM') then
                  isomers = .true.
                  read(linput,'(a)') instr
                  call ljust(instr)
                  Wname = instr
                  call upcase(Wname)

c                again, check if ioWell already assigned
                  ioWell = 0
                  do 300 jWell=1,nWells
                     if (Wname.eq.ISname(jWell)) ioWell = jWell
300               continue
                  if (ioWell.eq.0) then
                     nWells = nWells+1
                     if (nWells.gt.mxWells) then
                        write(lecho,160) mxWells
                        stop
                     endif
                     ioWell = nWells
                     ISname(ioWell) = Wname
                  endif

c                we now have proper ioWell
                  if (ioWell.eq.iWell) then
                     write(lecho,310) ISname(iWell)
                     write(lecho,*) iWell, ioWell
310                  format(/,' ERROR:  ',a,' isomerizes to itself.')
                     stop
                  endif

c                everything ok so continue input
                  read(linput,*,err=999) Aisom(iWell,ioWell),
     2               rNisom(iWell,ioWell),alphaIsom(iWell,ioWell),
     3               Eisom(iWell,ioWell)

c             override default freq parameters - freq
               else if (cmdstr(1:4).eq.'FREQ') then
                  read(linput,*,err=999) nfreqs(iWell),
     2               (freq(iWell,ifrq),degen(iWell,ifrq),
     3               ifrq = 1,min(nfreqs(iWell),mxfreqs))

                  if (nfreqs(iWell).gt.mxfreqs) then
                     write(lecho,145) mxfreqs
                     stop
                  endif
                  readfr(iWell) =.true.
                  FrRtRd(iWell) = .false.

c     20010808 dmm
c     read in frequency file and no. of free rotors
               else if (cmdstr(1:7).eq.'FR-READ') then
                  call VibRotRead(iWell)
                  readfr(iWell) = .true.
                  FrRtRd(iWell) = .true.

c             override default collision parameters
               else if (cmdstr(1:5).eq.'PARAM') then
                  read(linput,*,err=999) sig(iWell),ek(iWell)
                  readcp(iWell) =.true.

c             terminate Well loop; no pass
               else if (cmdstr(1:3).eq.'END') then
                  goto 100

c             terminate Well loop; pass command to upper level
               else
                  goto 110

               endif

            goto 200
c          end Well loop

c          terminate input loop and allow remainder of file for comments
            else if (cmdstr(1:4).eq.'COMM') then
               goto 450

            else
               write(lecho,360) instr
360               format(/,' ERROR: command not recognized: ',a,'.')
               stop

            endif

         goto 100
450      continue
c    end command loop

c----------------------------------------------------------------------c
c *** RRKM 1 k(E) Thread *** START                                     c
c----------------------------------------------------------------------c
c     dmm 20011018 entry point for separately reading TS data for 1 k(E)
c     RRKM substitution ...
         if(RRKM) then
            iTS = nWells + 1
            fname=ISname(i1RRKM)
            isp = INDEX(fname, ' ')
            if((isp.ne.0).and.(isp.le.(LEN(fname)-2))) then
               fname(isp:(isp+1))='TS'
            else
               fname((LEN(fname)-1):LEN(fname)) = 'TS'
            endif
            ISname(iTS) = fname
            call VibRotRead(iTS)
            FrRtRd(iTS) = .true.
         endif
c----------------------------------------------------------------------c
c *** RRKM 1 k(E) Thread *** END                                       c
c----------------------------------------------------------------------c

c    all done reading
c    fill out default Well parameters if not specified

      do 550 iWell = 1,nWells
         if (.not.readfr(iWell)) then
            if (readdf) then
               nfreqs(iWell) = nfdef
               do 510 ifrq = 1,nfreqs(iWell)
                  freq(iWell,ifrq) = freqdef(ifrq)
                  degen(iWell,ifrq) = degendef(ifrq)
510            continue
            else
               write(lecho,530) ISname(iWell)
530            format(/,' ERROR: FREQUENCIES not specified for ',a)
               stop
            endif
         endif

         if (.not.readcp(iWell)) then
            if (readdc) then
               sig(iWell) = sigdef
               ek(iWell) = ekdef
            else
               write(lecho,540) ISname(iWell)
540            format(/,' ERROR: COLLISION parameters not ',
     2            'specified for ',a)
               stop
            endif
         endif
550   continue

c	begin pey (4/6/04)
c	fill in temp and pres arrays if TRANGE and PRANGE keywords used
c	(also fill in the tcheb and pcheb arrays if using Chebyshev fitting)

	if(cheby) then !space points at Gauss-Chebyshev points in 1/T and log10(P)

		if (trange.and.prange) then

			if (ntemps.lt.nChebT .or. npres.lt.nChebP) then
			   write(lecho,'(2A)') 'Error: Number T and P points ',
     >           'specified in TRANGE,PRANGE must be >= CHEBYSHEV vals.'
	           stop
			endif

      		do it=1,ntemps
				tcheb(it) = cos(pi*(float(it) - 0.5)/float(ntemps))
				temp(it) = 1.0/((tcheb(it)*(1.0/tmax - 1.0/tmin)
     >                           + 1.0/tmin + 1.0/tmax)/2.0)
			enddo

			do ip=1,npres
				pcheb(ip) = cos(pi*(float(ip) - 0.5)/float(npres))
				pres(1,ip)=10.0**((pcheb(ip)*(log10(pmax)-log10(pmin))
     >                           + log10(pmin) + log10(pmax))/2.0)
			enddo

		else
			write(lecho,'(2A)') 'TRANGE and PRANGE keywords must be',
     >		 ' used with CHEBYSHEV keyword.'
              stop
		endif
      else ! not cheby
		if(trange) then ! space temperature points linearly
			deltat = (tmax-tmin)/float(ntemps-1)
			do it=1,ntemps
				temp(it) = tmin + deltat*float(it-1)
			enddo
		endif
		if(prange) then ! space pressure points linearly
			deltap = (pmax-pmin)/float(npres-1)
			do ip=1,npres
				pres(1,ip) = pmin + deltap*float(ip-1)
			enddo
		endif
	endif

c	end pey

c     fill out remainder of p matrix
      if (fillp) then
         do 570 it = 1,ntemps
            do 570 ip = 1,npres
               pres(it,ip) = pres(1,ip)
570      continue
      endif

c    finish collider specification and recompute total mole fractions
      if (ncolls.gt.0) then
c       remormalize x's
         do 620 icoll = 1,ncolls
            xcoll(icoll) = xcoll(icoll)/xtot
620      continue

c    otherwise if no input do default option
      else
         collNM(1) = 'N2'
         xcoll(1) = 1.
         ncolls = 1
         call lookup(collNM(1),rmass2(1),sig2(1),ek2(1),deltaE(1),
     2      noinfo)
         if (noinfo) then
             write(lecho,580) collNM(1)
             stop
         endif
         collNM(1) = 'DEFAULT'
         beta(1) = 0.2d0
         consbeta(1) = .true.
      endif

c    checking for other errors
      if (chemact.and.(.not.readin)) then
         write(lecho,660)
660      format(/,1x,'ERROR: INPUT rate required for CHEMACT ',
     2      'calculation.')
         stop
      endif
      if (chemact.and.(numRC.ne.1)) then
         write(lecho,670) numRC
cjmg fix
c670      format(/,1x,'ERROR: ',i2,' REACTANT channels specified '
c     2      'for CHEMACT calculation.')
670      format(/,1x,'ERROR: ',i2,' REACTANT channels specified '
     2      ,'for CHEMACT calculation.')
         stop
      endif
      if (nWells.lt.1) then
         write(lecho,680)
680      format(/,1x,'ERROR: no Well info specified.')
         stop
      endif

      return

c    flag read errors
999   continue
      write(lecho,1000) instr
cjmg fix
c1000  format(/,' ERROR:  reading input file after ',a'.')
1000  format(/,' ERROR:  reading input file after ',a,'.')
      stop

      end

c *************** [add'l routines removed to cdsets.f]*********

c ECHOPARAMS******************
      subroutine echoparams(lecho)

      implicit none
      include 'cdparams.fh'
      include 'cdwell0.fh'
      include 'cdwell1.fh'
      include 'cdwell2.fh'
      include 'cdisprop.fh'
      include 'cdcolls.fh'
      include 'cdlabels.fh'
      include 'cdcontrl.fh'

c    local variables
      integer iWell,ioWell,iProd,ifrq,icoll,n,iter
      integer lecho,nloops,nstop,Niter
c    end declarations

      write(lecho,10) caseStr
10    format(/,1x,'TAG ID: ',a)

      write(lecho,40) rmass
40    format(/,1x,'ISOMER MASS: ',f5.2,' amu')

      write(lecho,75)
75    format(/,1x,'FREQUENCIES (cm-1)')

      do 100 iWell = 1,nWells

c       we output 3 on a line
         if (mod(nfreqs(iWell),3).eq.0) then
            Niter = nfreqs(iWell) / 3
         else
            Niter = nfreqs(iWell) / 3 + 1
         endif

         write(lecho,80) iWell,ISname(iWell),
     2      (degen(iWell,ifrq),freq(iWell,ifrq),
     3      ifrq = 1,min(3,nfreqs(iWell)))
80       format(1x,i2,2x,a20,2x,3(2x,f5.2,' x',f7.1))

c       no trip do's
         do 90 iter = 2,Niter
           write(lecho,85) (degen(iWell,ifrq),freq(iWell,ifrq),
     2         ifrq = 3*iter-2,min(3*(iter),nfreqs(iWell)))
85          format(17x,3(2x,f5.2,' x',f7.1))
90       continue
100   continue

      if (nRot.ne.0) write (lecho,120)
120   format(/,1x,'One active rotation assumed.')

      if (chemact) then
         nloops = (nWells-1)/5 +1
         write(lecho,240)
240      format(/,1x,'ISOMERIZATION CHANNEL A''S')
         do 290 n = 1,nloops
            nstop = min(5*n,nWells)
            write(lecho,250) (isname(ioWell), ioWell = 5*n-4,nstop)
250         format(1x,10x,5(2x,a10))
            do 280 iWell = 1,nWells
               write(lecho,270) ISname(iWell),(Aisom(iWell,ioWell),
     2            ioWell = 5*n-4,nstop)
270            format(1x,a20,5(2x,1pe10.4))
280         continue
290      continue

         write(lecho,300)
300      format(/,1x,'ISOMERIZATION CHANNEL N''S')
         do 330 n = 1,nloops
            nstop = min(5*n,nWells)
            write(lecho,250) (isname(ioWell), ioWell = 5*n-4,nstop)
            do 320 iWell = 1,nWells
               write(lecho,310) ISname(iWell),(rNisom(iWell,ioWell),
     2            ioWell = 5*n-4,nstop)
310            format(1x,a20,5(2x,1pe10.4))
320         continue
330      continue

         write(lecho,335)
335      format(/,1x,'ISOMERIZATION CHANNEL alpha''S')
         do 360 n = 1,nloops
            nstop = min(5*n,nWells)
            write(lecho,250) (isname(ioWell), ioWell = 5*n-4,nstop)
            do 350 iWell = 1,nWells
               write(lecho,340) ISname(iWell),(alphaIsom(iWell,ioWell),
     2            ioWell = 5*n-4,nstop)
340            format(1x,a10,5(2x,1pe10.4))
350         continue
360      continue

         write(lecho,380)
380      format(/,1x,'ISOMERIZATION CHANNEL E''S (kcal)')
         do 400 n = 1,nloops
            nstop = min(5*n,nWells)
            write(lecho,250) (isname(ioWell), ioWell = 5*n-4,nstop)
            do 390 iWell = 1,nWells
               write(lecho,370) ISname(iWell),(Eisom(iWell,ioWell),
     2            ioWell = 5*n-4,nstop)
370            format(1x,a10,5(2x,f7.3,3x))
390         continue
400      continue

      endif

      write(lecho,420)
420   format(/,1x,'PRODUCT CHANNELS ',24x,
     2      '   A   ',4x,'   n',4x,'  alpha    ',1x,' E (kcal)')
      do 450 iWell = 1,nWells
         if (nProds(iWell).gt.0) then
            do 440 iProd = 1,nProds(iWell)
               write(lecho,430) iWell,iProd,ISname(iWell),
     2            PDname(iWell,iProd),AProd(iWell,iProd),
     3            rnProd(iWell,iProd),alphaProd(iWell,iProd),
     4            EProd(iWell,iProd)
cjmg fix
c430            format(1x,i2':',i2,2x,a,' = ',a,1pe10.4,2x,
c     2            0pf6.3,2x,1pe9.3,3x,0pf8.3)
430            format(1x,i2,':',i2,2x,a,' = ',a,1pe10.4,2x,
     2            0pf6.3,2x,1pe9.3,3x,0pf8.3)
440         continue
         endif
450   continue

      write(lecho,580)
cjmg fix
c580   format(/,1x,'COLLIDERS',5x,'  x  ',4x,'  m  ',4x,' sigma',3x,
c     2   '  e/k ',3x,'dEavg(300)',2x,'exp(dEd)',3x' beta')
580   format(/,1x,'COLLIDERS',5x,'  x  ',4x,'  m  ',4x,' sigma',3x,
     2   '  e/k ',3x,'dEavg(300)',2x,'exp(dEd)',3x,' beta')
      do 700 icoll = 1,ncolls
         if (consbeta(icoll)) then
            write(lecho,620) collNM(icoll),xcoll(icoll),rmass2(icoll),
     2         sig2(icoll),ek2(icoll),beta(icoll)
620         format(1x,a,3x,f5.3,4x,f5.1,4x,f6.2,4x,f6.2,5x,21x,f5.3)
         else
            write(lecho,650) collNM(icoll),xcoll(icoll),rmass2(icoll),
     2         sig2(icoll),ek2(icoll),deltaE(icoll),dEExp(icoll)
650         format(1x,a,3x,f5.3,4x,f5.1,4x,f6.2,4x,f6.2,5x,f6.1,
     2         5x,f6.3)
         endif
700   continue

      if (rkold) then
         write(lecho,710)
710      format(/,' Stabilization rates computed with RKOLD option.')
      endif

      return
      end

c***********************************************************************
c***********************************************************************
c     Subroutine VibRotRead
c
c     dmm 20010808
c
c     This subroutine is called from getparams when FFILE keyword
c     appears where the "FREQ" keyword normally would in fort.10.  It
c     reads a set of frequencies from an input file of the name '
c     ISname(iWell)'.dat.  The format of the file should be
c
c     line 1  no. of freq   no. of free rotors   no. of hindered rotors
c     lines 2-xx frequency table as per sumathy's tstuni.f
c     input, typically a 3-column table of frequencies (free format)
c
c     number of hindered rotors is read in but ignored for now;
c     eventually, should read in fourier forms for the surfaces,
c     geometry/external modes, and figure out cross-correlations?, then
c     solve Sch. eq'n for energy levels, somehow send these to density
c     -of-states routines
c
c     ikrot = flag to indicate whether k-rotor MOMI will be read or not
c***********************************************************************
c***********************************************************************

      SUBROUTINE VibRotRead(iWell)

      implicit none
      include 'cdparams.fh'
      include 'cdisprop.fh'
      include 'cdlabels.fh'
      include 'cdcontrl.fh'

      integer iWell, ilen, isp, ifin
      integer ihrot, ifrot, i, ikrot
      logical isthere
      character fname*20

c     Construct the correct input file name and open

      fname = ISname(iWell)
      isp = INDEX(fname, ' ')
      if(isp.ne.0) then
         ifin = isp - 1
      else
         ifin = LEN(fname)
      endif

c     see if this file exists before proceeding
      inquire(file = ''//fname(1:ifin)//'.dat', EXIST = isthere)
      if(.not.isthere) then
         write(*, 110), fname(1:ifin)
         stop
      endif

c     open and read data
      open(100, file = ''//fname(1:ifin)//'.dat')
      read(100,*) nFreqs(iWell), n1drot(iWell), ihrot, ikrot
      if(nFreqs(iWell).gt.mxFreqs) then
         write(*, 111), ISname(iWell)
         stop
      endif

      read(100,*) (freq(iWell,i), i=1,nFreqs(iWell))

c----------------------------------------------------------------------c
c *** RRKM 1 k(E) Thread *** START                                     c
c----------------------------------------------------------------------c
c     if ikrot flag is set, then read the moment of inertia for this
c     rotor (normally should only be needed for the RRKM hack option).
c     This will be in cm-1

      if(ikrot.eq.1) then
         read(100,*) rotk(iWell)
      else
         rotk(iWell) = -1.0
      endif
c----------------------------------------------------------------------c
c *** RRKM 1 k(E) Thread *** END                                       c
c----------------------------------------------------------------------c

c     placeholder:  may need to set degen vector to 1.0 values
c     everywhere ...

 110  format(1X,'<<ERROR>>: failed to find freq-rotor input file '
     $     ,A20, 1x, ' ..., stopping')

 111  format(1X, '<<ERROR>>: number of freqs read for ', A20,' more ',
     $   'than mxFreqs')

      end

c***********************************************************************
c***********************************************************************

c $Id$
c $Author$
c $Date$
c $Revision$
c $Log$
c Revision 1.2  2007-03-09 02:37:51  sandeeps
c Made changes so that dimensionless T in chebyshev polynomial is what it is in chemkin and
c not like the original venkatesh paper.
c
c Revision 1.1.1.1  2007/02/20 23:10:23  sandeeps
c Fortran_software contain
c 1. therfir
c 2. chemdis
c 3. reactorModel (chemkin, as modified by Paul)
c 4. ODESolver (the fortran code which RMG uses to call daspk or dassl)
c 5. fit3pbnd
c
c Revision 1.17  2001/10/18 20:58:35  dmmatheu
c before changes to allow 1 RRKM k(E) table to be calculated a la BARKER
c option ...
c
c Revision 1.16  2001/10/18 19:52:16  dmmatheu
c before editing to generate a k(E) from RRKM estimate (hack)
c
c Revision 1.15  2001/09/20 00:00:48  dmmatheu
c before changing Wname length to 15 from 20 (originally 10???)  trying
c to get H+cyclohexene to work.  QRRK.input file generated with 15
c character strings for the WELL lines but 20 character strings for the
c ISOMER lines (!!!!) ARRRGH! hard to fix.
c
c Revision 1.14  2001/09/19 00:03:51  dmmatheu
c during changes to try to get longer wellnames for debugging in
c H+cyclohexene
c
c Revision 1.13  2001/08/08 19:32:20  dmmatheu
c Version before adding VibRotRead, to read a list of frequencies and
c the number of free rotors (hindered rotors not yet supported) for the
c well from a file.
c
c Revision 1.12  2001/06/13 14:07:02  dmmatheu
c After changes to turn Barker file outputs on/off, major debug of
c mxWells and mxProds (zeroing loops of MakeShadow were exceeding array
c bounds).
c
c Added barker logical variable to this file, and lines to check for
c BARKER keyword in input file, which when used causes barker files to
c be printed
c
c Revision 1.11  2000/08/29 00:35:19  dmmatheu
c after tlada changes -- added absolute Rmin criteria, new printing
c line.
c
c Revision 1.10  2000/08/18 13:13:34  dmmatheu
c tlada added NOSUMISOM keyword to specify that individual pathway
c fluxes and not the sum of fluxes to all nonincluded isomers should be
c used to decide whether to add more isomers.
c
c Revision 1.9  2000/07/07 01:01:10  dmmatheu
c Checking in Tom's changes (lots) ... rmin criteria flag, input well
c specification fix (specify by well name for dissoc, not number)
c
c Revision 1.7  2000/06/27 18:20:07  dmmatheu
c before ASA additions ...
c
c Revision 1.6  2000/06/23 17:39:35  dmmatheu
c after Tom Lada merge
c
c Revision 1.5  2000/06/23 17:37:05  dmmatheu
c before merge with Tom Lada code
c
c Revision 1.4  2000/03/30 18:05:00  dmmatheu
c set Beyer-Sweinhart grainsize (bsgs) default to 10 cm-1
c
c Revision 1.3  2000/03/30 17:59:56  dmmatheu
c added bsgs variable and cdnos.fh
c
c Revision 1.2  2000/02/25 01:32:58  dmmatheu
c before adding gamma table check ...
c

max_issues_repo_name: bslakman/RMG-Java

max_forks_repo_name: bslakman/RMG-Java


text:
      SUBROUTINE pofs(re, ro, ns, rthom, itse)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ns, itse
      REAL(rprec), DIMENSION(ns) :: re, ro
      REAL(rprec), DIMENSION(*) :: rthom
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: j, js, i
      REAL(rprec), DIMENSION(ns) :: s
      REAL(rprec) :: sqrjs, rt2, ds
C-----------------------------------------------
!
!       Interpolate Rmid = Re + Ro to get R(s)
!
!       THIS ROUTINE INTERPOLATES THE RTHOM "S-SPACE" ARRAY
!       ONTO THE INSTANTANEOUS RMID ARRAY
!       ON INPUT, RTHOM IS THE S-VALUE ARRAY FOR THOMPSON DATA
!       ON OUTPUT,RTHOM IS THE CORRESPONDING (THETA=0) RMID ARRAY
!
      DO j = 1, ns
         s(j) = REAL(j - 1,rprec)/(ns - 1)
      END DO

      js = 1
      DO i = 1, itse
         rt2 = rthom(i)
  100    CONTINUE
         IF (rt2.ge.s(js) .and. rt2.le.s(js+1)) THEN
            ds = (rt2 - s(js))/(s(js+1)-s(js))
            sqrjs = SQRT(rt2)
            rthom(i) = re(js) + (re(js+1)-re(js))*ds + sqrjs*
     1         (ro(js)+(ro(js+1)-ro(js))*ds)
         ELSE
            js = js + 1
            IF (js < ns) GOTO 100
         ENDIF
      END DO

      END SUBROUTINE pofs

ext: f


text:
      SUBROUTINE HORADR( NOUT, LERR, LDBUG, SHORTO, FRADIU,
     &	MAXLST, BNDNO, BNDBRK, BNDR, VDWNO, VDWBRK, VDWRES, VDWR)
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1995 Oliver Smart & Birkbeck College, All rights reserved    *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date	Author		Modification
C 11/95	O.S. Smart	First version
C
C
C This s/r reads deals with opening radius file reading
C atomic bond and vdW radius record for HOLE.

C output stream no (to user)
      INTEGER			NOUT

C if an error found is found in s/r - set lerr true and program will stop,
C debug vbles
      LOGICAL			LERR, LDBUG

C  variable to reduce text output -
C if oshort =
C 0: full text output
C 1: no in run progress reported
C 2: ditto plus no graph type output - only leaving
C    Minimum radius & conductance calculations.
C 3: All text output other than input card mirroring
C    and error messages turned off
      INTEGER                   SHORTO

C radius filename
      CHARACTER*200		FRADIU

C maximum no of entries in lists
C (PARAMETER so dont change!)
      INTEGER			MAXLST

C bond radius list
      INTEGER			BNDNO
      CHARACTER*4		BNDBRK(MAXLST)
      DOUBLE PRECISION		BNDR(MAXLST)

C vdW radius list
      INTEGER			VDWNO
      CHARACTER*4		VDWBRK(MAXLST)
      CHARACTER*3		VDWRES(MAXLST)
      DOUBLE PRECISION		VDWR(MAXLST)

C internal vbles ***************

C input stream number
      INTEGER			SIN

C line to read info
      CHARACTER*132		LINE

C function to open files readonly
      LOGICAL			OPENRO

C end of decs ******************

C the reading of radius file and pdb file copied from
C program TooShort

C open vdw/bond radius file (to stream sin)
      IF (.NOT.OPENRO( SIN, FRADIU, NOUT)) THEN
C cannot open radius file
        WRITE(NOUT,*) '*** ERROR ***'
        WRITE(NOUT,*) 'Cannot open bond/vdw radius input file:'
        WRITE(NOUT,*) FRADIU(1:INDEX(FRADIU,'     ')-1)
        LERR = .TRUE.
        GOTO 55555
      ENDIF

C read bond and vdw radii from file
      CALL TSRADR( SIN, NOUT, LERR, LDBUG,
     &  MAXLST, BNDNO, BNDBRK, BNDR, VDWNO, VDWBRK, VDWRES, VDWR)
      IF (LERR) GOTO 55555

C tell user extact filename and no of records read
      INQUIRE( SIN, NAME = LINE)
      IF (SHORTO.LT.3) WRITE( NOUT, '(/3(A,I6,A/))')
     &' Have read',  BNDNO, ' bond radius records and',
     &'          ',  VDWNO,' vdW radius records.',
     &' From file: '//LINE(1:INDEX(LINE,'   ')-1)

C close RADIUS file
      CLOSE( SIN)

55555 RETURN
      END


text:
c
c
c     =====================================================
      subroutine flux1(maxm,meqn,maux,mbc,mx,
     &                 q1d,dtdx1d,aux1,
     &                 faddm,faddp,cfl1d,wave,s,
     &                 amdq,apdq,cqxx,bmasdq,bpasdq,rp1)
c     =====================================================
c
c     # clawpack routine ...  modified for AMRCLAW
c
c     # Compute the modification to flux f that is generated by
c     # all interfaces along a 1D slice of the grid.
c     # This value is passed into the Riemann solver. The flux modifications
c     # go into the array fadd.  The notation is written assuming
c     # we are solving along a 1D slice in the x-direction.
c
c     # fadd(*,i,.) modifies F to the left of cell i
c
c     # The method used is specified by method(2):
c
c         method(2) = 1 if only first order increment waves are to be used.
c                   = 2 if second order correction terms are to be added, with
c                       a flux limiter as specified by mthlim.
c
c     Note that if mcapa>0 then the capa array comes into the second
c     order correction terms, and is already included in dtdx1d:
c        dtdx1d(i) = dt/dx                      if mcapa= 0
c                  = dt/(dx*aux(mcapa,i,jcom))  if mcapa = 1
c
c     Notation:
c        The jump in q (q1d(i,:)-q1d(i-1,:))  is split by rp1 into
c            amdq =  the left-going flux difference  A^- Delta q
c            apdq = the right-going flux difference  A^+ Delta q
c
c
      use amr_module
      implicit double precision (a-h,o-z)
      external rp1
      dimension    q1d(meqn,1-mbc:maxm+mbc)
      dimension   amdq(meqn,1-mbc:maxm+mbc)
      dimension   apdq(meqn,1-mbc:maxm+mbc)
      dimension   cqxx(meqn,1-mbc:maxm+mbc)
      dimension   faddm(meqn,1-mbc:maxm+mbc)
      dimension   faddp(meqn,1-mbc:maxm+mbc)
      dimension dtdx1d(1-mbc:maxm+mbc)
      dimension aux1(maux,1-mbc:maxm+mbc)
c
      dimension     s(mwaves, 1-mbc:maxm+mbc)
      dimension  wave(meqn, mwaves, 1-mbc:maxm+mbc)
c
      logical limit
      common /comxt/ dtcom,dxcom,tcom,icom
c
      limit = .false.
      do 5 mw=1,mwaves
         if (mthlim(mw) .gt. 0) limit = .true.
   5     continue
c
c     # initialize flux increments:
c     -----------------------------
c
       do 10 i = 1-mbc, mx+mbc
         do 20 m=1,meqn
            faddm(m,i) = 0.d0
            faddp(m,i) = 0.d0
   20    continue
   10  continue
c
c
c     # solve Riemann problem at each interface and compute Godunov updates
c     ---------------------------------------------------------------------
c
      call rp1(maxm,meqn,mwaves,maux,mbc,mx,q1d,q1d,
     &          aux1,aux1,wave,s,amdq,apdq)
c
c     # Set fadd for the donor-cell upwind method (Godunov)
      do 40 i=1,mx+1
         do 40 m=1,meqn
            faddp(m,i) = faddp(m,i) - apdq(m,i)
            faddm(m,i) = faddm(m,i) + amdq(m,i)
   40       continue
c
c     # compute maximum wave speed for checking Courant number:
      cfl1d = 0.d0
      do 50 mw=1,mwaves
         do 50 i=1,mx+1
c          # if s>0 use dtdx1d(i) to compute CFL,
c          # if s<0 use dtdx1d(i-1) to compute CFL:
            cfl1d = dmax1(cfl1d, dtdx1d(i)*s(mw,i),
     &                          -dtdx1d(i-1)*s(mw,i))
   50       continue
c
      if (method(2).eq.1) go to 130
c
c     # modify F fluxes for second order q_{xx} correction terms:
c     -----------------------------------------------------------
c
c     # apply limiter to waves:
      if (limit) call limiter(maxm,meqn,mwaves,mbc,mx,wave,s,mthlim)
c
      do 120 i = 1, mx+1
c
c        # For correction terms below, need average of dtdx in cell
c        # i-1 and i.  Compute these and overwrite dtdx1d:
c
c        # modified in Version 4.3 to use average only in cqxx, not transverse
         dtdxave = 0.5d0 * (dtdx1d(i-1) + dtdx1d(i))

c
c        # second order corrections:

         do 120 m=1,meqn
            cqxx(m,i) = 0.d0
            do 119 mw=1,mwaves
c
               if (use_fwaves) then
                   abs_sign = dsign(1.d0,s(mw,i))
                 else
                   abs_sign = dabs(s(mw,i))
                 endif

               cqxx(m,i) = cqxx(m,i) + abs_sign
     &             * (1.d0 - dabs(s(mw,i))*dtdxave) * wave(m,mw,i)
c
  119          continue
            faddm(m,i) = faddm(m,i) + 0.5d0 * cqxx(m,i)
            faddp(m,i) = faddp(m,i) + 0.5d0 * cqxx(m,i)
  120       continue
c
c
  130  continue
c
      return
      end

max_stars_repo_name: navravi/amrclaw

max_issues_repo_name: navravi/amrclaw

max_forks_repo_name: BrisaDavis/amrclaw


text:
c_______________________________________________________________
c blendscon2 (rutina del programa inversion)
c igual que la rutina fstokes0 pero teniendo en cuenta blends
c calcula las funciones respuesta de I
c para un angulo heliocentrico de coseno mu. se supone lte,
c el maximo numero de puntos en tau es 64
c Basilio Ruiz (23 julio 93)
c ______________________________________________________________
c
c ist=1 (i); =2 (q); =3 (u); =4 (v)

	subroutine blendscon2(atmos,inten,rt,rp,rv,rm,mnodos)

	include 'PARAMETER'

c para las funciones respuesta
	real*4 rt(*),rp(*),rv(*),rm(*)
	real*4 grt(kt),grp(kt),grv(kt),grm(kt)
	real*4 x(kt)

c para los perfiles
	real*4 atmos(*),inten(*),icont

c para la atmosfera
	real*4 tau(kt),t(kt),pe(kt),vtur(kt),vz(kt),bp(kt),bt(kt)
	real*4 taue(kt),dbp(kt),vof(kt),logpe(kt)
	real*4 continuoh,conhsra,dplnck,dtplanck
	integer mnodos(*)

c para la matriz de absorcion y sus derivadas
	real*4 dab(kt),tk(kt),pk(kt),vk(kt),mk(kt)
	real*4 dabtot(kt,kld)
	real*4 tktot(kt,kld),pktot(kt,kld),mktot(kt,kld),vktot(kt,kld)
        real*4 www,dyt(kt),dyp(kt),alpha(kt),depar(kt)

c para la malla
	real*4 dlongd(kld),dlamda0(kl)
	real*4 wlengt,wlengt1,lambda,dlamda,wvac,wc,c
	integer nlin(kl),npas(kl),ist(4),nble(kl)

c para los parametros atomicos y coeficientes de absorcion
	real loggf,nair,mvdop,meta0,ma
	real*4 y(kt),table(kt,16)
	real*4 ck5(kt),dk5(kt),ddk5(kt),zeff
	real*4 ckappa,ckappa5,dkappa,dkappa5,ddkappa,ddkappa5
        real*4 beta1(kl,kt),beta2(kl,kt)

c para el patron zeeman

	character atom*2
	integer mult(2)
	real tam(2),abu,piis

c para las presiones parciales
	integer ivar(10)
	real pg(99),dpg(99),ddpg(99),pi(10),dpi(10),ddpi(10)
	real pt(kt,10),dpt(kt,10),ddpt(kt,10)
        real*4 pgas(kt),dpgas(kt),ddpgas(kt)      !,ro(kt),ck5_ro(kt)

c para la inclusion de RP en RT
        real*4 ax(kt),bx(kt),cx(kt),dx(kt),d1x(kt),d2x(kt),fx(kt)
        real*4 px(kt),qx(kt),rx(kt),sx(kt),tx(kt),wx(kt,kt)
        real*4 kac,kat,kap

c para hermite_c
	real*4 deltae(kt),deltai(kt),delt2i(kt)

c para barklem
        real*4 bol,pir,v0,melectron,mhidrogeno,xmasaproton,avo,borh,uma
	real*4 gas,coc2,coc3

c lugares comunes de memoria
	common/responde2/ist,ntau,ntl,nlin,npas,nble
	common/ldeo/dlongd,dlamda0
	common/nlte/nlte
	common/piis/piis
	common/yder/y,dyt,dyp,alpha  !coef. de abs. del continuo y su der. t,p

        common/segunda/tau,taue,deltae,deltai,delt2i
        common/offset/voffset  !para respuestas
        common/iautomatico/iautomatico
c        common/mu/cth                              !esto esta puesto a 1 en sir
        common/anguloheliocent/xmu
        common/departcoef/beta1,beta2

	data iprimera/0/

c nble es el numero de componentes de cada linea
	c=2.99792458e+10 	!vel. de la luz en cm/seg
	piis=1./sqrt(3.1415926)

	g=xmu*2.7414e+4	 !gravedad cm/s^2 en fotosfera solar
       	avog=6.023e23

        bol=1.3807e-16         !erg/s
        pir=3.1415926
        v0=1e6                 !cm/s
        melectron=9.1094e-24
        mhidrogeno=1.67442e-24
        xmasaproton=1.6526e-24
        avo=6.023e23
        bohr=0.0529177249e-7   !cm
        uma=1.660540e-24
        gas=8.31451e7         !constante de los gases en cgs

c       polh=6.6e-25           ! polarizabilidad de HI
        coc3=1.212121          ! cociente polarizabilidad del H2 con HI
        coc2=.3181818          ! idem para el He

	ntotal=0
	do i=1,ntl
	   do j=1,npas(i)
		ntotal=ntotal+1
	   end do
	end do

	if(iprimera.eq.0)then
	   do i=1,ntau
	      tau(i)=atmos(i)
	      taue(i)=10.**(tau(i))
	   end do
	   do i=1,ntau-1
              deltae(i)=taue(i)-taue(i+1)
           end do
	   do i=2,ntau
              deltai(i)=(tau(i)-tau(i-1))/2.d0
	      delt2i(i)=deltai(i)*deltai(i)/3.d0
           end do

	   paso=tau(1)-tau(2)

           iprimera=1
	end if

        x(1)=g*(tau(1)-tau(2))*2.3025851          !AQUI BRC
        do i=1,ntau-1                             !AQUI BRC
           x(i+1)=g*(tau(i)-tau(i+1))*2.3025851   !AQUI BRC
        end do                                    !AQUI BRC

c leemos la atmosfera
	do i=1,ntau
	   t(i)=atmos(i+ntau)
	   pe(i)=atmos(i+2*ntau)
	   logpe(i)=alog(pe(i))
	   vtur(i)=atmos(i+3*ntau)
           vz(i) =atmos(i+5*ntau)       !velocidad lines de vision
           vof(i)=vz(i)-voffset
	end do

	do i=1,ntau
           alpha(i)=1.
	   depar(i)=1.
        end do
	if(nlte.eq.1)call alphasub(tau,ntau,alpha,depar)

c calculamos el peso molecular medio pmu
	pmusum=0.0
        asum=0.0
	do i=1,92
  	   ii=i
	   call neldatb(ii,0.,wgt,abu,ei1,ei2)
	   pmusum=pmusum+wgt*abu
           asum=asum+abu
	end do

c calculo las presiones parciales (pg) y las derivadas de sus logaritmos
c con respecto a la t (dpg) y, con pe (ddpg)

	ivar(1)=1
	ivar(2)=2
	ivar(3)=6
	ivar(4)=11
	ivar(5)=12
	ivar(6)=86
	ivar(7)=89
	ivar(8)=90
	ivar(9)=91
	ivar(10)=93

	do i=1,ntau
	    ps=pe(i)
	    ts=t(i)
	    theta=5040./ts
	    call gasb(theta,ps,pg,dpg,ddpg)
	    do j=1,10
	       k=ivar(j)
	       pt(i,j)=pg(k)
               dpt(i,j)=dpg(k)
               ddpt(i,j)=ddpg(k)
	       pi(j)=pg(k)
	       dpi(j)=dpg(k)
	       ddpi(j)=ddpg(k)
	    end do
            pgas(i)=pg(84)      !presion gaseosa
            dpgas(i)=dpg(84)    !der. log(presion gaseosa) respectp a T
            ddpgas(i)=ddpg(84)  !der. log(presion gaseosa) respectp a pe
	    call kappach(5.e-5,ts,ps,pi,dpi,ddpi,ck5(i),dk5(i),ddk5(i))
            cc=avog/pmusum
            kac=ck5(i)*cc
            kat=dk5(i)*cc
            kap=ddk5(i)*cc
            tauk=taue(i)/2./kac/kac

            fx(i)=dpg(84)*pg(84)
            cx(i)=1./(ddpg(84)*pg(84))
            bx(i)=kap/(ddpg(84)*pg(84))
            ax(i)=kat-kap*dpg(84)/ddpg(84)
C       AQUI!!!!!!!  LA X ESTA SIN DEFINIR. LA SENTENCIA X(I)=0 LA PONGO YO.
C            x(i)=0.                                !AQUI BRC
c            d1x(i)=x(i+1)*tauk
            d1x(i)=x(i)*tauk
C       HASTA AQUI!!!! Y ADEMAS X(I+1) SE SALE DE LIMITES CUANDO I=NTAU Y LO SUTITUYO
C                        ARBITRARIAMNENTE POR X(I).
            d2x(i)=x(i)*tauk
            dx(i)=1.+d1x(i)*bx(i)

	end do

        rx(ntau)=0.
        sx(ntau)=0.
        tx(ntau)=0.
        do i=1,ntau-1
           rx(i)=(1.- d2x(i+1)*bx(i+1))/dx(i)
           sx(i)=(d2x(i+1)/dx(i))*ax(i+1)
           tx(i)=(d1x(i)/dx(i))*ax(i)
           px(i)=-cx(i)*(tx(i)+fx(i))
        end do

        do i=2,ntau
           qx(i)=-cx(i-1)*(sx(i-1)+tx(i)*rx(i-1))
        end do
        qx(1)=0.

        do i=1,ntau-1
c          deltapei=px(i)*deltat(i)+qx(i+1)*deltat(i+1)
           do j=1,i+1
              wx(i,j)=0.
           end do
           do j=ntau-1,ntau
              wx(i,j)=0.
           end do
           do j=i+2,ntau-2
              r1=1.
              do k=i,j-2
                 r1=r1*rx(k)
              end do
              wxi=-(sx(j-1)+tx(j)*rx(j-1))*r1
              wx(i,j)=cx(i)*wxi

           end do
        end do

c datos de la linea
	ikk0=0
	ikk1=0
        ixx=0
	do 999 iln=1,ntl	!iln=numero de la linea,ntl num.total
	   do i=1,npas(iln)
	      do k=1,ntau
	           dabtot(k,i)=0.
	           tktot(k,i)=0.
	           pktot(k,i)=0.
	           vktot(k,i)=0.
	           mktot(k,i)=0.
	       end do
	    end do
	    do ible=1,nble(iln)
	       ixx=ixx+1
	       nxx=nlin(ixx)
	       if(nxx.eq.0)then
                  nxx=nlin(ixx-1)
	          call leelineasii(nxx,atom,istage,wlengt,zeff,energy,
     &                         loggf,mult,design,tam,alfa,sigma)
                  loggf=-20.
                  wlengt=5000.
               else
	          call leelineasii(nxx,atom,istage,wlengt,zeff,energy,
     &                         loggf,mult,design,tam,alfa,sigma)
	       end if
	       gf=1.e1**(loggf)
	       if(ible.eq.1)wlengt1=wlengt
	       dlamda0(iln)=wlengt
 	       continuoh=conhsra(wlengt1)

c parametros atomicos
c llamo a atmdat que devuelve weight (peso molecular),abu (abunda
c cia), chi1,chi2 (pot.de ionizacion del atomo neutro e ion),
c u1,u2,u3 (funciones de particion atomo neutro,ion,ion2).

	call atmdatb(atom,0.,nel,weight,abu,chi10,chi20,u1,u2,u3,
     &		     du1,du2,du3)

c constantes y parametros
c calculo la l.d.o. en el vacio (wvac), con la function refrax
        nair=1.0004
	if(wlengt.ge.1800.)nair=refrax(wlengt*1.e-4,15.,760.,0.)
	lambda=wlengt*1.e-8	!l.d.o. en el aire en cm.
	wvac=nair*lambda        !l.d.o. en el vacio en cm.
	wc=wvac/c		!inverso de la frecuekta (segundos)

c calculo de terminos constantes.
	weinv=1./weight
	croot=1.66286e+8*weinv  !2r/m  para anchura doppler(cm**2/s**2)
	dlo=4.6686e-5*wvac*wvac !separac.de l.d.o=dlo*h*(m1*g1-m2*g2)
	crad=.22233/wvac        !(l.d.o.*coef.clasico ensanch. natural)
	eta00=1.49736e-2*gf*abu*wvac !para el coef. de absor.de la linea

c calculo chydro (gamma6)coef.van der waals ensanch.colisional
c corregido con zeff (termino 'semiempirico' caca de la vaca)
c (se supone despreciable el debido a stark)
c si el damping asi calculado es mayor que 3 lo reescalaremos

        if(alfa.eq.0..or.sigma.eq.0.)then

	chi1=chi10
	if(istage.eq.2)chi1=chi20
	eupper=energy+1.2398539e-4/wvac
	ediff1=amax1(chi1-eupper-chi10*float(istage-1),1.0)

	ediff2=amax1(chi1-energy-chi10*float(istage-1),3.0)
	chydro=lambda*1.e1**(+.4*alog10(1./
     &	ediff1**2-1./ediff2**2)-12.213)*5.34784e+3

	chydro=chydro*zeff

	if(istage.eq.2)chydro=chydro*1.741

       else

c xmu1 es la masa reducida del hidrogeno y el atomo.Los indices 2 y 3 hacen
c referencia al helio neutro y al hidrogeno molecular.

           xmu1=uma*(1.008*weight)/(1.008+weight)
           xmu2=uma*(4.0026*weight)/(4.0026+weight)
           xmu3=uma*(2.016*weight)/(2.016+weight)

           arr=2.-alfa*.5-1.
           gammaf=1.+(-.5748646+(.9512363+(-.6998588+(.4245549-
     &              .1010678*arr)*arr)*arr)*arr)*arr
           vv=(1.-alfa)/2.

           beta=lambda*2*(4./pir)**(alfa/2.)*gammaf*(v0**alfa)*sigma*
     &          ((8.*bol/pir)**vv)

        endif

c estratificacion en tau 5000
c genero una tabla lineal en logaritmo de tau a l.d.o.=5000.angs.
c desde tauini a taufin, con ntau valores.

	do 71 i=1,ntau
	    ps=pe(i)
	    ts=t(i)
	    theta=5040./ts

	    do j=1,10
	       k=ivar(j)
	       pi(j)=pt(i,j)
               dpi(j)=dpt(i,j)
               ddpi(j)=ddpt(i,j)
	       pg(k)=pi(j)
	       dpg(k)=dpi(j)
	       ddpg(k)=ddpi(j)
	    end do

c calculo el coeficiente de absorcion del continuo por cm**3
c (ckappa) y sus derivadas con respecto a t y pe:dkappa,
c ddkappa y lo divido por dicho coef. evaluado a 5000.a
c calculo el ckappa para lambda=(5000 a=5.e-5 cm),(ckappa5)

	    call kappach(lambda,ts,ps,pi,dpi,ddpi,ckappa,
     &                       dkappa,ddkappa)
	    ckappa5=ck5(i)
            dkappa5=dk5(i)
            ddkappa5=ddk5(i)

            ckappa=ckappa/ckappa5
	    dkappa=(dkappa-ckappa*dkappa5)/ckappa5
	    ddkappa=(ddkappa-ckappa*ddkappa5)/ckappa5
	    dkappa5=dkappa5/ckappa5
	    ddkappa5=ddkappa5/ckappa5

c	calculo vdop=(delta doppler*c/l.d.o.) y su derivada
c	    vdop=sqrt(croot*ts+vtur(i)**2) !cm/seg.
c            dvdop=croot/vdop/2.
c	    mvdop=vtur(i)/vdop

            vdop=sqrt(croot*ts+vtur(i)**2) !cm/seg.
            vdop2=sqrt((2.*gas*ts)/weight+vtur(i)**2)
            dvdop=croot/vdop/2.
            dvdop2=gas/(vdop2*weight)
            mvdop=vtur(i)/vdop

c calculo el coeficiente absorcion linea en cada tau y sus derivadas
c calculo eta0=(coef.absorcion linea/coef. absorcion continuo)
c necesito calcular la fraccion de atomos del elemento en el
c el nivel de la transicion respecto al numero total de atomos
c del elemento en cualquier estado de ionizacion.asi, tengo que
c utilizar las ecuacione de saha y boltzmann.
c llamare u12 al cociente de poblaciones entre el estado de ioniza
c cion 1 (neutro) y 2.igualmente u23 entre los iones 2 y 3
c necesito llamar a nelfctb (definida en atmdatb con un 'entry')
c para calcular las funciones de particion y sus derivadas a cada
c temperatura
	   call nelfctb(nel,ts,u1,u2,u3,du1,du2,du3)

c corrijo los potenciales de ionizacion chi10 y chi20 con
c un termino proporcional a la raiz cubica de la densidad de e-

	   rcu=(pg(91))**(1./3.)
	   chi1=chi10-6.96e-7*rcu
	   chi2=chi20-1.1048e-6*rcu

	   u12=saha(theta,chi1,u1,u2,ps)      !n2/n1
	   du12=u12*dsaha(theta,chi1,du1,du2) !derivada de u12 con t
	   ddu12=-1.*u12/ps        !    "    "   "  con pe
	   u23=saha(theta,chi2,u2,u3,ps)      !n3/n2
	   du23=u23*dsaha(theta,chi2,du2,du3) !derivada de u23 con t
	   ddu23=-1.*u23/ps                !    "    "   "  con pe
	   u33=1.+u12*(1.+u23)                !(n1+n2+n3)/n1
	   du33=du12*(1.+u23)+u12*du23
	   ddu33=ddu12*(1.+u23)+u12*ddu23

    	   eta0=eta00*1.e1**(-theta*energy)/(u1*vdop*u33*ckappa5)
	   deta0=eta0*(alog(10.)*theta/ts*energy-du1-dvdop/vdop-du33/u33)
	   deta0=deta0-eta0*dkappa5
	   ddeta0=eta0*(-ddu33/u33)
	   ddeta0=ddeta0-eta0*ddkappa5

	   if(istage.eq.2)then
		eta0=eta0*u1/u2*u12
		deta0=deta0*u1/u2*u12+eta0*(du1-du2+du12/u12)
		ddeta0=ddeta0*u1/u2*u12+eta0*(ddu12/u12)
	   end if

c introduzco la correccion por emision estimulada
	   corre=1.-exp(-1.4388/(ts*wvac))
	   dcorre=(corre-1.)*(1.4388/(ts*ts*wvac))
	   deta0=deta0*corre+eta0*dcorre
	   eta0=eta0*corre
	   meta0=-eta0*mvdop/vdop

c calculo el damping 'a' mediante Unsold
c despreciaremos la dependencia del damping con t o pe en el calcu
c lo de las funciones respuesta.
c pg(1)=p(h)/p(h'),pg(90)=pe/p(h'),pg(91)=densidad de e-
c pg(2)=p(he)/p(h'),pg(89)=p(h2)/p(h')
c   a=(chydro*(pg(1)/pg(90)*pg(91))*t(i)**0.3*((.992093+weinv)**.3
c  &  +.6325*pg(2)/pg(1)*(.2498376+weinv)**.3+.48485*pg(89)/pg(1)*
c  &  (.4960465+weinv)**.3)+crad)/(12.5663706*vdop)

        if(sigma.eq.0.or.alfa.eq.0)then
            if(pg(1).gt.1.e-20)then !EVITAMOS DAMPING NULO POR PG(1)=0

	    aj=chydro*(pg(1)/pg(90)*pg(91))*ts**0.3
	    ai=(.992093+weinv)**.3+.6325*pg(2)/pg(1)*(.2498376+weinv)**.3+
     &	    .48485*pg(89)/pg(1)*(.4960465+weinv)**.3
	    a=(aj*ai+crad)/(12.5663706*vdop)
	    ma=-a*mvdop/vdop

	    daj=aj*(dpg(1)-dpg(90)+dpg(91)+.3/ts) !derivada de aj cont
	    ddaj=aj*(ddpg(1)-ddpg(90)+ddpg(91))  !derivada de aj con p

	    dai=.6325*pg(2)/pg(1)*(.2498376+weinv)**.3*(dpg(2)-dpg(1))+
     &	    .48485*pg(89)/pg(1)*(.4960465+weinv)**.3*(dpg(89)-dpg(1))
	    ddai=.6325*pg(2)/pg(1)*(.2498376+weinv)**.3*(ddpg(2)-ddpg(1))+
     &	     .48485*pg(89)/pg(1)*(.4960465+weinv)**.3*(ddpg(89)-ddpg(1))

	    da=(ai*daj+aj*dai)/(12.5663706*vdop)-a*dvdop/vdop
	    dda=(ai*ddaj+aj*ddai)/(12.5663706*vdop)

            else  !CORRECCION PARA EVITAR DAMPING NULO POR PG(1)=0

            aj=chydro*(1./pg(90)*pg(91))*ts**0.3
            ai=.6325*pg(2)*(.2498376+weinv)**.3+
     &	      .48485*pg(89)*(.4960465+weinv)**.3
	    a=(aj*ai+crad)/(12.5663706*vdop)
	    ma=-a*mvdop/vdop

	    daj=aj*(-dpg(90)+dpg(91)+.3/ts) !derivada de aj cont
	    ddaj=aj*(-ddpg(90)+ddpg(91))  !derivada de aj con p
	    dai=.6325*pg(2)*(.2498376+weinv)**.3*dpg(2)+
     &	    .48485*pg(89)*(.4960465+weinv)**.3*dpg(89)
	    ddai=.6325*pg(2)*(.2498376+weinv)**.3*ddpg(2)+
     &	     .48485*pg(89)*(.4960465+weinv)**.3*ddpg(89)

c              AQUI!!! CREO QUE FALTAN ESTAS DOS SENTENCIAS
	    da=(ai*daj+aj*dai)/(12.5663706*vdop)-a*dvdop/vdop
	    dda=(ai*ddaj+aj*ddai)/(12.5663706*vdop)
c              HASTA AQUI!!!

            end if !CORRECCION PARA EVITAR DAMPING NULO POR PG(1)=0

	else

c       calculo del damping 'a' mediante BARKLEM.
c       d son las derivadas totales respecto a la temperatura.
c       dd son las derivadas totales respecto a la presion.

           dam=beta*(pg(91)/pg(90))*(pg(1)*xmu1**(-vv)+coc2*pg(2)*(xmu2**(-vv))
     &      +coc3*pg(89)*xmu3**(-vv))*ts**vv

           a=(1./(4.*pir))*(crad/vdop+dam/vdop2)
           ma=-a*mvdop/vdop

           ddam=dam*(dpg(91)-dpg(90))+beta*(pg(91)/pg(90))*(xmu1**(-vv)*pg(1)*
     &       dpg(1)+coc2*xmu2**(-vv)*pg(2)*dpg(2)+coc3*pg(89)*dpg(89)
     &       *xmu3**(-vv))*ts**(vv)+vv*(dam/ts)

           dddam=dam*(ddpg(91)-ddpg(90))+beta*(pg(91)/pg(90))*(xmu1**(-vv)*
     &     pg(1)*ddpg(1)+coc2*xmu2**(-vv)*pg(2)*ddpg(2)+coc3*pg(89)*ddpg(89)*
     &     xmu3**(-vv))

           da=(crad/(4.*pir))*(-dvdop/(vdop**2.))+(1./(4.*pir))*(ddam*vdop2-
     &     dam*dvdop2)/(vdop2**2.)
           dda=(1./(4.*pir))*(dddam/vdop2)

        endif

c calculo la funcion de planck en lambda y su derivada con t
c la function "dtplanck" calcula la derivada de la f. de planck
c con la temperatura.
                www=wlengt1*1.e-8
 		bp(i)=dplnck(t(i),www)  !cuerpo negro
 	        bt(i)=dtplanck(t(i),www)

                if(nlte.eq.0)then
                   blow=1.
                   bratio=1.
                else
                   blow=beta1(ixx,i)
                   bratio=blow/beta2(ixx,i)
                end if

                call planck2(t(i),www,bratio,tonto1,tonto2)
                bp(i)=tonto1
                bt(i)=tonto2

                eta0=eta0*blow
                deta0=deta0*blow
                ddeta0=ddeta0*blow
                meta0=meta0*blow

                y(i)=ckappa              !ckappa/ckappa5
                dyt(i)=dkappa
                dyp(i)=ddkappa
                table(i,1)=dkappa        !derivada con t
                table(i,2)=ddkappa       !    "     "  pe
		table(i,3)=eta0    !kap. linea/kcont.5000
		table(i,4)=deta0   !derivada con t
		table(i,5)=ddeta0  !derivada con pe
		table(i,6)=wc*vdop !despl. doppler en l.d.o(cm)
		table(i,7)=vz(i)/vdop !velocidad eje z (u.doppler)
		table(i,8)=dkappa5       !derivada con t de kappacon5
		table(i,9)=ddkappa5      !  "       "  pe      "
                table(i,10)=a      !damping
		table(i,11)=da	 !derivada del damping con t
		table(i,12)=dda    !derivada del damping con p
		table(i,13)=dvdop/vdop   !derivada de log(vdop) con t
	        table(i,14)=mvdop/vdop   !   "      "    "      con mic
	        table(i,15)=meta0	 !derivada de eta0 con la micro
	        table(i,16)=ma   	 !derivada de a    con la micro
71	continue            !do en log(tau)

c	call deriva(bp,dbp,ntau,kt,TOTAL)
        call derivacuad(bp,dbp,ntau,tau)

	amaxim=0.
	do i=1,ntau
       	   if(table(i,10).ge.amaxim)amaxim=table(i,10)
	end do

	if(amaxim.gt.3.)then
	   do i=1,ntau
	      table(i,10)=(3.*table(i,10))/amaxim
	      table(i,11)=(3.*table(i,11))/amaxim
	      table(i,12)=(3.*table(i,12))/amaxim
	      table(i,16)=(3.*table(i,16))/amaxim
	   end do
	end if

c muestreo en lambda , calculo las l.d.o. de cada punto
   	do 10 i=1,npas(iln)
	   ikk=ikk0+i
	   if(ible.eq.nble(iln).and.i.eq.npas(iln))ikk0=ikk0+npas(iln)
	   dlamda=(dlongd(ikk)+(wlengt1-wlengt)*1.e3)*1.e-11  !en cm.

c calculo etar,etal,etap y sus derivadas
	   do 101 j=1,ntau     !do en tau
	      a=table(j,10)	!damping
	      dldop=table(j,6) !desplazamiento doppler en cm
	      dvcam=table(j,7) !campo de velocidades unidades doppler
	      v=dlamda/dldop-dvcam !(l.d.o.+c.vel.) en unidades doppler
	      if(ible.eq.1)then
	      	t0=y(j)		!coef. absor. continuo/c.a.c 5000
	      	t1=table(j,1)     !derivada de t0 con t
	      	t2=table(j,2)     !  "         "      pe
	      else
	        t0=0.
	        t1=0.
	        t2=0.
	      end if
	      t3=table(j,3)     !coef. absor. linea/c.a.c 5000
	      t4=table(j,4)     !derivada de t3 con t
	      t5=table(j,5)     !  "         "   "  pe
	      t15=table(j,15)   !  "         "   "  micro
	      t11=table(j,11)   !derivada del damping con t
	      t12=table(j,12)   !  "       "     "     "  pe
	      t16=table(j,16)   !  "       "     "     "  micro
	      t13=table(j,13)   !derivada de log(vdop) con t
	      t14=table(j,14)   !  "      "      "      "  micro

	      call mvoigtc(a,v,t13,t14,wc,dldop,etar,vetar,
     &	                   ettar,ettvr,ettmr)

              dabtot(j,i)= dabtot(j,i)+t0 +t3*etar
              tktot(j,i) = tktot(j,i) +t1 +t4*etar + t3*(ettar*t11+ettvr)
              mktot(j,i) = mktot(j,i)     +t15*etar+ t3*(ettar*t16+ettmr)
              pktot(j,i) = pktot(j,i) +t2 +t5*etar + t3* ettar*t12
              vktot(j,i) = vktot(j,i)              + t3* vetar

101	     continue !fin do en tau(estamos aun dentro del do en lamda)
10	  continue	!fin del do en lambda(pasos)
	end do   !fin del do en blends
c	................................................................
	do 9 i=1,npas(iln)
	   do k=1,ntau
	      dab(k)=dabtot(k,i)
	      tk(k)=tktot(k,i)
	      pk(k)=pktot(k,i)
              vk(k)=vktot(k,i)
	      mk(k)=mktot(k,i)
	   end do

c	   call contp(bp,dbp,dab,ntau,icont,kt,bt,tk,pk,vk,mk,
c     &             grt,grp,grv,grm)
	   call hermite_c(bp,dbp,dab,ntau,icont,kt,bt,tk,pk,vk,mk,
     &             grt,grp,grv,grm)

c introducimos el paso en tau para pasar la integral sobre las f. resp.
c a sumatorio y normalizmos por el continuo
c las perturbaciones son relativas por tanto las funciones respuesta equi
c valentes en los nodos son multiplicadas por el valor del parametro
c en el nodo (en 'nodos')
c !ojo las perturbaciones son relativas a los parametros en z no a linea vision

        ikk1=ikk1+1
        if(mnodos(1).ne.0)then
           if(mnodos(2).eq.0.)then
	      do kk=1,ntau  !introduccion de grp en grt
                 suma=0.
                 do kj=1,kk-2
                    suma=suma+wx(kj,kk)*grp(kj)
                 end do
                 correc=grp(kk)*px(kk)+suma
	         if(kk.gt.1)correc=correc+grp(kk-1)*qx(kk)
                 grt(kk)=grt(kk)+correc
              end do
           end if
	   call rnorma(ntau,continuoh,grt)
           if(iautomatico.ne.1.or.mnodos(1).eq.1)call
     &        nodos(grt,ntau,tau,t,mnodos(1))	  !al final de blends2
        end if
        if(mnodos(2).ne.0)then
	   call rnorma(ntau,continuoh,grp)
           if(iautomatico.ne.1.or.mnodos(2).eq.1)call
     &        nodosp(grp,ntau,tau,pe,mnodos(2))    !OJO nodosp escala con la pe en el ultimo nodo
        end if                                     !rutina al final de blends2
        if(mnodos(3).ne.0)then
           call rnorma(ntau,continuoh,grm)
           if(iautomatico.ne.1.or.mnodos(3).eq.1)call
     &        nodos(grm,ntau,tau,vtur,mnodos(3)) !al final de blends2
        end if
        if(mnodos(5).ne.0)then
	   call rnorma(ntau,continuoh,grv)
          if(iautomatico.ne.1.or.mnodos(5).eq.1)call
     &        nodos(grv,ntau,tau,vof,mnodos(5)) !al final de blends2

        end if

c las f. respuesta salen ordenadas en longitud de onda,perfil y tau
c rt(tau1:i(l1,l2,...);tau2:i......)
	      do j=1,mnodos(1)
	         iktt=(j-1)*ntotal+ikk1
		 rt(iktt)=grt(j)
	      end do
	      do j=1,mnodos(2)
	         iktt=(j-1)*ntotal+ikk1
		 rp(iktt)=grp(j)
	      end do
	      do j=1,mnodos(3)
	         iktt=(j-1)*ntotal+ikk1
		 rm(iktt)=grm(j)
	      end do
	      do j=1,mnodos(5)
	         iktt=(j-1)*ntotal+ikk1
		 rv(iktt)=grv(j)
	      end do

	inten(ikk1)=icont/continuoh
c        print*,'blendscon2',ikk1,inten(ikk1)
9 	continue	!fin del do en lambda
999	continue	!fin del do en lineas

	return
	end

max_stars_repo_name: cdiazbas/SIRcode

max_issues_repo_name: cdiazbas/SIRcode

max_forks_repo_name: cdiazbas/SIRcode


text:
Debats du Senat (hansard)
2e Session, 36e Legislature,
Volume 138, Numero 23
Le jeudi 16 decembre 1999
L'honorable Gildas L. Molgat, President
L'Association parlementaire Canada-Europe
Ces Canadiennes qui ont marque notre histoire
L'etat de sante du senateur Willie Adams
Depot de la reponse du gouvernement au rapport du comite special
La situation actuelle du regime financier canadien et international
Presentation du rapport du comite des banques et du commerce
Regie interne, budgets et administration
Depot du troisieme rapport du comite
La Loi sur la statistique La Loi sur les Archives nationales du Canada
Projet de loi modificatif-Premiere lecture
L'Association parlementaire Canada-Europe
L'Association interparlementaire Canada-France
L'agriculture et l'agroalimentaire
Les difficultes des cerealiculteurs de l'Ouest
Les difficultes des cerealiculteurs de l'Ouest- L'attente d'une reponse du premier ministre
Demande de reponse au rapport du comite sur les anciens combattants autochtones
Projet de loi de credits no 3 pour 1999-2000
Projet de loi de 1999 pour la mise en oeuvre de conventions fiscales
Projet de loi sur l'Accord definitif nisga'a
Deuxieme lecture-Ajournement du debat
Projet de loi modificatif-Deuxieme lecture- Suite du debat
Projet de loi modificatif-Deuxieme lecture-Report du debat
Adoption du deuxieme rapport du comite mixte permanent
Adoption du premier rapport du comite mixte permanent
Le rapport du comite des affaires etrangeres-Report du debat
Adoption du rapport du comite des peuples autochtones
Affaires sociales, sciences et technologie
Autorisation au comite d'examiner l'etat du systeme de sante
Les recommandations de la Commission royale sur les peuples autochtones relativement a la fonction gouvernementale
Autorisation donnee au comite de reporter le depot du rapport final
L'octroi d'un statut bilingue a la ville d'Ottawa- Adoption de la motion
Le jeudi 16 decembre 1999
La seance est ouverte a 14 heures, le President etant au fauteuil.
L'assistant en question, c'est bien sur Richard Greene.
Je veux assurer a Richard que nous serons toujours amis.
Je partage ces souvenirs avec Richard Greene.
Ils indiquent ce qui va se produire dans cette enceinte.
Richard etait un professionnel consomme.
Je vous remercie pour ces annees pendant lesquelles nous avons travaille ensemble, Richard.
Vous allez nous manquer.
L'honorable Marcel Prud'homme :
Honorables senateurs, il y a ici une intrigue que nous n'avions pas vue.
Je crois que cet evenement a beaucoup marque M. Greene.
M. Greene et moi avons souvent voyage et travaille ensemble.
J'espere sincerement que c'est ce qui va arriver.
L'Association parlementaire Canada-Europe
L'honorable Jerahmiel S. Grafstein :
Vous remarquerez que l'Amerique du Nord et l'Europe sont geographiquement de proches voisins.
Tout cela sera possible, economiquement, au debut du prochain siecle.
Je profite de cette occasion pour souhaiter a tous les senateurs un heureux nouveau millenaire.
Ces Canadiennes qui ont marque notre histoire
En tant que societe, nous leur devons beaucoup.
Faute de temps, je ne saurais nommer tout le monde.
Nous celebrons cette annee le soixante-dixieme anniversaire de l'affaire personne.
Mme Therese Casgrain a ete la premiere Canadienne a diriger un parti politique.
Le congres existe encore aujourd'hui, un temoignage durable de ses efforts.
Entre autres heroines canadiennes, mentionnonsElizabeth Bagshaw, le docteur Marion Powell et le docteurLise Fortier.
Elle a dirige la clinique de l'Ontario, illegalement, de 1932 a 1966.
Le docteur Powell a fait de meme a Toronto.
Toutes on fait preuve de courage, de tenacite, de leadership et de talent.
Et puissent ces paroles de Nellie McClung inspirer nos heroines de demain:
L'etat de sante du senateur Willie Adams
Le pronostic est excellent.
Son Honneur le President :
Depot de la reponse du gouvernement au rapport du comite special
L'honorable Dan Hays (leader adjoint du gouvernement) :
La situation actuelle du regime financier canadien et international
Presentation du rapport du comite des banques et du commerce
Le jeudi 16 decembre 1999
Le Comite senatorial permanent des banques et du commerce a l'honneur de presenter son
Ce rapport fut adopte par le Senat le mardi 14 decembre 1999.
Son Honneur le President :
Honorables senateurs, quand etudierons-nous le rapport?
Regie interne, budgets et administration
Depot du troisieme rapport du comite
Son Honneur le President :
Permission accordee, honorables senateurs?
Gary n'a pas besoin de presentation.
Il nous sert fidelement et bien.
C'est un enseignant.
Par-dessus tout, Gary nous a fourni un service hors pair.
C'est une de ces personnes pour lesquelles le mot service a un sens.
Je sais qu'il conservera cette attitude dans son nouveau poste.
Permettez-moi de raconter une histoire apocryphe.
C'etait un habit pour un homme de faible taille et d'assez forte constitution.
Richard avait tout ce qu'il fallait pour heriter de cet habit.
Il a obtenu le poste et il est avec nous depuis ce temps.
Ca, c'est l'exercice du pouvoir.
Richard, je vous transmets aussi les felicitations de Gerry et de Nicky.
Nous leur souhaitons la bienvenue dans leurs nouvelles fonctions.
Nous les felicitons et nous les remercions de leur travail dans le passe.
Nous les remercions du service de haute qualite qu'ils nous ont fourni.
Son Honneur le President :
L'honorable Pierre Claude Nolin:
C'est un homme tres efficace, par contre, tres reserve.
Le jeudi 16 decembre 1999
Le Comite senatorial permanent des affaires juridiques et constitutionnelles a l'honneur de presenter son
Page 18, article 19:
a) Substituer, a la ligne 25, ce qui suit:
b) Ajouter, apres la ligne 38, ce qui suit:
Son Honneur le President :
Honorables senateurs, quand etudierons-nous ce rapport?
La Loi sur la statistique La Loi sur les Archives nationales du Canada
Projet de loi modificatif-Premiere lecture
(Le projet de loi est lu une premiere fois.)
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une deuxieme fois?
L'Association parlementaire Canada-Europe
L'honorable Jerahmiel S. Grafstein :
L'Association interparlementaire Canada-France
L'agriculture et l'agroalimentaire
L'honorable Leonard J. Gustafson :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Je pose des questions a ce sujet depuis un an et demi.
Ce comite a fait de l'excellent travail.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Le premier ministre a-t-il rencontre le comite?
Ce comite a fait un merveilleux travail - et j'etais la pour le voir.
Sur quel terrain de golf est-il?
C'est ce qu'il faut decouvrir.
Les difficultes des cerealiculteurs de l'Ouest
Honorables senateurs, j'ai une question complementaire a poser a cet egard.
Eh bien, le temps est venu de hausser le ton dans cette piece!
De ce cote-ci de l'enceinte, nous avons ete tres patients.
Nous posons ces questions depuis un an et demi.
Ce n'est pas comme si nous ne l'avions fait qu'hier.
Je l'ai fait moi aussi.
Peut-etre que le programme fait defaut.
Tout le monde sait au Canada que le programme fait defaut.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Il se contente d'en reclamer au gouvernement federal.
Il en est tres fier, et a juste titre d'ailleurs.
Les difficultes des cerealiculteurs de l'Ouest- L'attente d'une reponse du premier ministre
L'honorable A. Raynell Andreychuk :
Ensuite, il devra indiquer que des correctifs seront apportes.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Il y a eu un processus et il s'agissait d'un programme conjoint.
Il est vrai que le programme ne fonctionne pas comme il se doit.
Nous avons discute de cela ici et a d'autres endroits.
Le gouvernement federal a consacre 170 millions de dollars au programme.
Cela aurait ete compatible avec le programme conjoint.
Le gouvernement federal n'en a rien fait.
Comme ma mere le dirait, on ne repare pas une injustice par une autre injustice.
Il est responsable a l'egard de tout le pays.
Honorables senateurs, je comprends la preoccupation soulevee par le senateur Andreychuk.
L'honorable Jean-Robert Gauthier :
C'est donc un autre pave dans la mare!
L'honorable J. Bernard Boudreau (leader du gouvernement) :
J'ai pu me renseigner a ce sujet.
Elle exerce son autorite dans le cadre constitutionnel.
Cette autorite lui est conferee par une loi provinciale.
Toutefois, cela ne lui donne pas le droit de se declarer officiellement ville bilingue.
Hier, le ministre des Affaires intergouvernementales a declare ceci:
Le gouvernement a indique qu'il analyse les choix possibles.
Aucune decision n'a encore ete prise a cet egard.
L'honorable Gerald J. Comeau :
Honorables senateurs, le senateur a pose la question que j'avais en tete.
Je remercie l'honorable senateur de ce commentaire.
A cet egard, la municipalite n'a pas de pouvoir.
L'honorable Jerahmiel S. Grafstein :
J'ai pose une question au senateur Joyal au sujet du pouvoir de revocation.
Je crois comprendre qu'il est tombe en discredit.
Aucune d'entre elles ne constitue une solution privilegiee.
Je verrai a ce que cette solution soit aussi soumise au procureur general.
L'honorable Marcel Prud'homme :
Dans tout pays, il y a une capitale.
J'ai une approche differente.
C'est un autre debat.
C'est un debat tout a fait distinct.
Deuxiemement, ce n'est pas une question de debat partisan.
Les opinions des honorables senateurs sont bien connues et sont a prendre au serieux.
Je suis convaincu que le gouvernement les partage.
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
La question concerne l'expression meme.
L'honorable J. Michael Forrestall :
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, je suis au courant de la situation dont parle l'honorable senateur.
Ces negociations se deroulent comme toutes negociations.
On marchande des deux cotes, c'est donnant donnant.
On avance sa position, on fait des compromis.
Il a ete signe par les deux parties.
Honorables senateurs, cette breve rencontre a eu lieu il y a trois semaines ou plus.
Demande de reponse au rapport du comite sur les anciens combattants autochtones
L'honorable A. Raynell Andreychuk :
Bien des anciens combattants autochtones sont morts depuis la presentation du rapport.
La reponse du gouvernement est extremement importante pour ceux qui restent en vie.
Quand recevrons-nous la reponse du gouvernement?
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, c'est la premiere fois qu'on porte cette question a mon attention.
Son Honneur le President :
Honorables senateurs, je regrette, mais la periode des questions est maintenant terminee.
Projet de loi de credits no 3 pour 1999-2000
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
L'article 6, a la page 3 de ce projet de loi stipule que:
Sous la rubrique Presentation, au commentaire 933, nous pouvons lire:
Honorables senateurs, l'article 6 du projet de loi pose un probleme.
L'honorable Anne C. Cools :
Honorables senateurs, je remercie l'honorable senateur Kinsella de sa question.
Je le repete, une partie de la question du senateur m'a echappe.
Honorables senateurs, voici le probleme et voici le principe.
A la page 31 du projet de loi, l'annexe 2 prevoit ceci:
L'annexe 2 ajoute ceci:
Honorables senateurs, le projet de loi merite d'etre bien examine.
En outre, il remplissait son devoir de senateur.
Je suis reconnaissant du fait que nous serons tous payes.
(La motion est adoptee et le projet de loi, lu une troisieme fois, est adopte.)
Projet de loi de 1999 pour la mise en 9uvre de conventions fiscales
L'honorable John Lynch-Staunton (chef de l'opposition) :
Honorables senateurs, je remercie le senateur Cools de ce consentement royal, que j'apprecie enormement.
Comme ses observations ont ete bien suffisantes, je me ferai tres bref.
C'est une chose sur laquelle on insistera, je l'espere, avec les annees.
Ces dernieres sont toutes assez similaires.
Elles sont destinees a eviter la double imposition et l'evitement fiscal.
Sa reponse a ete la suivante:
Meme des sanctions multilaterales bien appliquees ne sont pas toujours particulierement efficaces.
Je ne partage pas ce point de vue.
Certaines personnes croient que l'engagement est la cle.
Je crois que l'isolement et les boycotts peuvent avoir plus d'effet.
Encore la, c'est une position hautement theorique pour le moment.
L'honorable Jerahmiel S.Grafstein :
Le senateur est-il pret a accepter une breve question?
Honorables senateurs, je remercie le senateur Grafstein de cette excellente suggestion.
L'honorable Celine Hervieux-Payette :
Je propose l'adoption du projet de loi S-3.
Projet de loi sur l'Accord definitif nisga'a
Deuxieme lecture-Ajournement du debat
Le projet de loi dont nous sommes saisis marquera l'histoire.
Les seules collectivites organisees dans la vallee de la Nass sont celles des Nisga'as.
Ils ont une culture complexe fondee sur les riches ressources de la mer.
On en trouve d'autres dans de nombreux musees dans le monde.
Aujourd'hui, sur 5 500 Nisgas'as, 2 500 vivent repartis dans quatre villages:
Kincolith, Greenville, Canyon City et New Aiyansh.
La plupart des autres Nisga'as vivent a Terrace, Prince Rupert ou Vancouver.
Ils attachent beaucoup d'importance a la scolarisation et a l'enseignement postsecondaire.
Les Nisga'as ont leur propre arrondissement scolaire, l'arrondissement scolaire 92.
Les membres du conseil scolaire, dont un resident non Nisga'a, sont elus.
Ils ont travaille en cooperation avec leurs voisins.
Leur voyage a Victoria a cependant ete infructueux.
En 1890, ils ont etabli leur premier comite charge de la question des terres.
En 1973, la Cour supreme a rendu sa decision dans l'affaire Calder .
Nous ne pouvons progresser qu'avec le plein assentiment de toutes les parties interessees.
Les negociations ont debute en 1976.
Le gouvernement nisga'a sera une gouvernement democratique a l'interieur du modele canadien etabli.
Ce gouvernement fonctionnera conformement aux dispositions de la Constitution du Canada.
Le traite enonce des conditions precises de la Constitution nisga'a qui doivent etre respectees.
Elles ne peuvent etre annulees par aucun gouvernement nisga'a a venir.
Il pourra et sera tenu politiquement et legalement responsable des decisions qu'il prendra.
Le traite etablit trois locaux urbains, soit Terrace, Prince Rupert et Grand Vancouver.
Penchons-nous maintenant sur les pouvoirs legislatifs des Nisga'as.
Elles doivent se plier a un certain nombre d'autres exigences.
Elles doivent etre egalement conformes a la Constitution nisga'a.
On le precise tres clairement dans le traite nisga'a.
Dans cette troisieme categorie, les lois federales et provinciales priment sur la loi nisga'a.
Comme je l'ai dit tout a l'heure, c'est un arrangement pratique.
L'Accord definitif nisga'a satisfait cet objectif.
Le maire de la ville de Terrace, Jack Talstra, a dit au comite permanent:
Nous adressons tous nos voeux a nos voisins nisga'as.
Allons de l'avant avec ce traite.
A l'avenir, les Nisga'as seront en mesure de developper les terres nisga'as.
Je dis a mes compatriotes de la Colombie-Britannique que cela n'est pas acceptable.
Ce n'est absolument pas le cas.
C'est une fausse croyance.
L'Accord definitif nisga'a adopte une approche axee sur la modification des droits.
Ce dernier a admis ceci dans son memoire au comite permanent de l'autre endroit:
Honorables senateurs, c'est exactement ce que nous avons fait.
Il a intente une action pour faire intervenir les tribunaux et en obtenir une interpretation.
Les tribunaux ont confirme que ces droits peuvent etre enfreints si cela se justifie.
Honorables senateurs, le traite nisga'a precise ce qui suit:
Plus loin, le professeur Monahan ajoute:
Leur pouvoir legislatif demeure intact.
On reproche egalement au projet de loi d'etre fonde sur la race.
Dans le meme article, il declare ce qui suit:
Il doit aussi y avoir une loi pour tous.
Tous les droits a la propriete privee sont entierement proteges.
Il est possible, au Canada, d'etre a la fois autochtone et canadien.
Ils attendent avec impatience de pouvoir se liberer de la dependance financiere.
Plus loin, il a ajoute:
L'article 35 compte parmi les dispositions importantes ayant ete adoptees a ce moment-la.
Le systeme fonctionne tres bien.
Est-ce le cas?
Je veux remercier le senateur Beaudoin de sa question.
Ainsi, il y a l'article 35 protegeant les droits prevus dans cet accord.
Le reste de l'accord ne me pose aucun probleme.
J'attends avec impatience cette etude.
Le senateur souleve un point essentiel.
L'honorable Gerald J. Comeau :
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Ma question s'adresse au senateur Austin.
Certains appellent cela le droit de reversion.
Son Honneur le President informe le Senat qu'il a recu la communication suivante:
L'honorable Le President du Senat Ottawa
Son Honneur le President :
La Loi sur le Parlement du Canada
Projet de loi modificatif-Deuxieme lecture- Suite du debat
L'honorable Eymard G. Corbin :
Neanmoins, je lui suis reconnaissant d'avoir saisi le Senat de cette proposition.
Il a eu des mois pour ce faire.
Je suis donc biaise, sachez-le.
Or, je retrouvais cette phrase de la main de Baudelaire, et je cite:
[...] et personne ne lui a repondu.
Stello defend un point de vue bien particulier, que je partage presque entierement.
Separer la vie poetique de la vie politique.
Et pour y parvenir:
Deuxieme prescription du Docteur Noir au poete:
Seul et libre, accomplir sa mission.
Parce que la Solitude seule est la source des inspirations.
Et j'en passe beaucoup, l'essentiel etant enonce.
Quelle est la frontiere entre le langage et le pouvoir?
Et c'est a l'honneur du poete.
Je le ferai pendant l'ajournement, apres les Fetes.
Qu'est-il arrive de notre capacite de reve, de nos talents d'explorateurs?
C'est comme si nous manquions de maturite pour innover.
Sommes-nous a ce point deficients?
Je ne parle pas pour le poete, j'exprime une conviction profonde.
Projet de loi modificatif-Deuxieme lecture-Report du debat
L'honorable Dan Hays (leader adjoint du gouvernement) :
Son Honneur le President :
Adoption du deuxieme rapport du comite mixte permanent
L'honorable Rose-Marie Losier-Cool :
Honorables senateurs, je propose l'adoption de ce rapport.
L'honorable Mabel M. DeWare :
(La motion est adoptee, et le rapport est adopte.)
Adoption du premier rapport du comite mixte permanent
L'honorable Celine Hervieux-Payette :
Honorables senateurs, je propose l'adoption de ce rapport.
Son Honneur le President :
Honorables senateurs, vous plait-il d'adopter la motion?
(La motion est adoptee, et le rapport est adopte.)
Le rapport du comite des affaires etrangeres-Report du debat
L'honorable Peter A. Stollery :
Honorables senateurs, j'aimerais que l'article no 4 demeure inscrit a mon nom.
Le comite des affaires etrangeres a ete tres occupe ces derniers temps.
Honorables senateurs, je propose l'adoption de ce rapport.
Son Honneur le President :
Honorables senateurs, vous plait-il d'adopter la motion?
(La motion est adoptee et le rapport est adopte.)
Vous devriez etre reconnaissants pour toutes ces bonnes choses que nous faisons pour vous.
Ne demandez surtout pas a etre reconnus pour ce que vous etes.
Ne vous attendez pas a ce qu'on vous accorde des droits.
Quelle impression en ressent-on?
Cela fait mal, honorables senateurs.
Ce n'est pas rien.
J'en rends hommage au gouvernement de l'Ontario.
Il n'y a surement aucun d'entre nous qui le conteste.
C'est egalement incontestable qu'Ottawa est un cas special.
La region de la capitale nationale n'est pas la capitale.
Au Canada, nous avons deux langues officielles.
C'est un des piliers de notre identite et de nos politiques nationales.
Cela souleve un probleme de ressort provincial.
Mais cela ne concerne en rien la ville d'Ottawa.
Il y a eu des precedents devant les tribunaux a cet effet.
Nous savons que certains milieux opposent une resistance a cette mesure.
Nous pouvons arriver a embrasser ce changement.
Ils n'ont jamais parle francais.
Ils etaient fiers que j'aie appris le francais.
Je leur suis eternellement reconnaissante de m'en avoir offert la possibilite.
Pourquoi avons des drapeaux, par exemple, si le symbolisme n'est pas important?
Le symbolisme est une chose extremement importante pour nous tous.
Et ou est-ce plus important que dans la capitale du pays?
Il est question que le gouvernement federal intervienne.
Son Honneur le President :
Aussitot qu'elle sera terminee, nous reprendrons le debat.
Le greffier du Senat donne lecture de la commission.
Qu'il plaise a Votre Honneur.
A ce projet de loi, je prie humblement Votre Honneur de donner la sanction royale.
La Chambre des communes se retire.
Il plait a l'honorable suppleant de Son Excellence la Gouverneure generale de se retirer.
Plusieurs Etats federaux ont une capitale bilingue, voire meme multilingue.
On doit respecter le partage des pouvoirs.
C'est deja beaucoup.
Je conclus que la capitale de notre pays se doit d'etre bilingue.
Honorables senateurs, j'ai ecoute avec beaucoup d'interet l'expose du senateur Beaudoin.
Vous avez soutenu que la partie VII avait un caractere executoire, et pas uniquement declaratoire.
Cette question fait actuellement l'objet d'un debat devant les tribunaux.
Honorables senateurs, dans le fond, nous souhaitons la meme chose.
Nous nous battons tous pour le meme resultat.
C'est conteste, mais c'est notre regime.
Il faut essayer de faire valoir nos arguments a la cour.
La capitale du Canada ne peut qu'etre bilingue.
Le Canada et le bilinguisme sont synonymes; ils ne font qu'un.
Depuis 1898, le Yukon a une communaute francophone tres active et fiere.
Aujourd'hui, ses membres sont representes par l'Association francophone yukonnaise.
C'est une question d'unite.
Ce n'etait pas necessaire.
L'honorable Marcel Prud'homme :
Honorables senateurs, il y a eu une entente.
Adoption du rapport du comite des peuples autochtones
Permission ayant ete accordee de revenir aux rapports de comite:
(La motion est adoptee, et le rapport est adopte.)
Affaires sociales, sciences et technologie
Autorisation au comite d'examiner l'etat du systeme de sante
Plus particulierement, que le Comite soit autorise a examiner:
a ) Les principes fondamentaux sur lesquels est fonde le systeme public de sante au Canada;
b ) L'historique du systeme de sante au Canada;
c ) Les systemes de sante publics dans d'autres pays;
d ) Le systeme de sante au Canada - pressions et contraintes;
e ) Le role du gouvernement federal dans le systeme de sante au Canada;
Que le Comite presente son rapport final au plus tard le 14 decembre 2001; et
L'honorable senateur Di Nino ).
Honorables senateurs, comme tous les autres membres du comite, j'appuie cette initiative.
La question merite une etude serieuse.
Nous devons faire face a de nombreuses realites.
Je demande respectueusement l'autorisation de faire cette etude.
Son Honneur le President pro tempore :
Y a-t-il d'autres senateurs qui desirent prendre la parole?
Honorables senateurs, je m'en tiendrai a deux breves observations.
Honorables senateurs, ce sont la les observations que je voulais faire.
Son Honneur le President pro tempore :
Vous plait-il, honorables senateurs, d'adopter la motion?
L'honorable Peter A. Stollery , conformement a l'avis du9 decembre 1999, propose:
Les recommandations de la Commission royale sur les peuples autochtones relativement a la fonction gouvernementale
Autorisation donnee au comite de reporter le depot du rapport final
2. les mecanismes necessaires a l'implantation des nouvelles relations structurelles;
L'octroi d'un statut bilingue a la ville d'Ottawa- Adoption de la motion
L'honorable Jean-Robert Gauthier , conformement a l'avis du 15 decembre 1999, propose:
J'espere que ce debat continuera d'etre apolitique.
Le mot officiel - si on se reporte a un dictionnaire - veut dire:
[...] qui emane d'une autorite reconnue, dument sanctionnee, autorisee, [...]
Honorables senateurs, je suis ne a Ottawa.
J'y ai passe toute ma vie.
Je demande a mes amis du Senat d'appuyer cette motion.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Notre province est officiellement bilingue.
La seule province au Canada a etre officiellement bilingue.
L'honorable Marcel Prud'homme :
Je me suis toujours considere comme l'adjoint du senateur Gauthier.
Honorables senateurs, il est tres facile de diviser pour se rendre populaire.
C'est trop facile.
J'etais cense transmettre les bons voeux de M. Pearson, qui devait rentrer a Ottawa.
Je n'ai jamais choisi la voie de la facilite, qui consiste a denoncer.
La moitie d'entre eux ne s'etaient jamais interesses a la politique.
C'est la raison pour laquelle je felicite le senateur Kinsella.
Il n'a pas peur d'exprimer son point de vue.
Je viens tout juste de rentrer du Pakistan et d'autres lieux.
C'est un pays constamment en voie de realisation.
Il faut parfois se garder de chercher vengeance, comme certains d'entre nous le font.
Honorables senateurs, chacun de nous a un devoir.
Nous devrions nous reengager au service du Canada.
L'honorable Norman K. Atkins :
Honorables senateurs, je tiens a feliciter le senateur Gauthier pour sa motion.
Honorables senateurs, j'interviens a propos de cette motion, et cela, pour deux grandes raisons.
Premierement, je tiens a appuyer le senateur Gauthier.
Le senateur Gauthier et moi avons ete elus tous deux en 1972.
Son Honneur le President :
Honorables senateurs, je suis desole de vous interrompre, mais il est 18 heures.
L'honorable Dan Hays (leader adjoint du gouvernement) :
Honorables senateurs, je propose de ne pas voir l'heure.
Son Honneur le President :
Etes-vous d'accord, honorables senateurs?
En tant qu'anglophones unilingues, nous avons du faire l'apprentissage du Canada.
Nous sommes encore nombreux a ne pas parler le francais.
Nous parlons la langue de Shakespeare.
Je vois le senateur Cochrane qui me fait des remontrances.
Nous ne cherchons pas a nous justifier.
Ce sont les autres qui ont change la langue anglaise, pas nous.
Le statut linguistique d'Ottawa n'est affaire ni de francophones, ni d'anglophones.
C'est une affaire nationale.
Cette disposition est importante.
C'est pourquoi j'appuie cette motion, honorables senateurs.
Le senateur Gauthier a ete mis sur terre pour intervenir dans un moment semblable.
Plus nous nous eloignons du centre, plus la lutte devient difficile.
Cette question constitue un champ de bataille.
Je suis fiere d'appuyer mon collegue, le senateur Gauthier, sur cette question.
Bien sur qu'ils le sont!
Senateur Gauthier, je vous remercie.
Apres l'avoir nettoye, ma mere l'a mis sur un support, dans le salon.
L'honorable Francis William Mahovlich :
Nous avons remporte un tres gros succes, et 1972 a ete une tres bonne annee.
Honorables senateurs, j'aimerais signifier mon appui a cette motion du senateur Gauthier.
Je pensais que vous tiendriez pour acquis que j'appuierais cette motion.
Bien sur que je le fais.
Nous devons encourager les gens a respecter les deux langues officielles du pays.
C'est tout a fait sans condition et j'appuie sincerement cette motion.
Honorables senateurs, nous constatons aujourd'hui quelle place le Senat occupe dans notre pays.
Toutes les equipes qui nous appuient meritent nos felicitations.
L'honorable Louis J. Robichaud :
Un autre domaine aussi nous est cher, le bilinguisme.
Nous voudrions tellement cesser les luttes chez nous.
Nous voudrions tellement ne pas avoir a lutter pour que le bilinguisme soit officiellement reconnu.
Je n'avais pas l'intention de dire quoi que ce soit.
J'appuie tres clairement le bilinguisme.
Son Honneur le President :
Si aucun autre senateur ne desire prendre la parole, je vais proceder.
Vous plait-il d'adopter la motion, honorables senateurs?
Son Honneur le President :
Est-ce d'accord, honorables senateurs?
L'honorable Mabel A. DeWare :
L'honorable Dan Hays (leader adjoint du gouvernement) :
Permission ayant ete accordee de revenir aux avis de motion du gouvernement:
L'honorable Dan Hays (leader adjoint du gouvernement) :
Son Honneur le President :
La permission est-elle accordee, honorables senateurs?
Son Honneur le President :
Je souhaite a tous un tres Joyeux Noel et une tres Bonne Annee.
J'offre a tous mes meilleurs v9ux pour le nouvel an.
(Le Senat s'ajourne au mardi 8 fevrier 2000, a 14 heures.)