text:
! This file is part of flox.
! SPDX-Identifier: Apache-2.0

module flox_diagnostic
  use flox_terminal, only : lox_terminal
  implicit none
  private

  public :: render, operator(==)
  public :: lox_diagnostic, label_type

  interface render
    module procedure render_diagnostic
    module procedure render_text
    module procedure render_text_with_label
    module procedure render_text_with_labels
  end interface render

  interface operator(==)
    module procedure op_equal
  end interface operator(==)

  !> Enumerator for diagnostic levels
  type :: level_enum
    !> Raw identifier for enumerator
    integer :: id
  end type level_enum

  !> Actual enumerator values
  type(level_enum), parameter, public :: &
    level_error = level_enum(0), &
    level_syntax_error = level_enum(1), &
    level_eof_error = level_enum(2), &
    level_semantic_error = level_enum(3), &
    level_runtime_error = level_enum(4), &
    level_warning = level_enum(10), &
    level_help = level_enum(20), &
    level_note = level_enum(30), &
    level_info = level_enum(40)

  type label_type
    !> Level of message
    type(level_enum) :: level
    !> Primary message
    logical :: primary
    !> Line number of message
    integer :: line
    !> First and last character of message
    integer :: first, last
    !> Message text
    character(len=:), allocatable :: text
    !> Identifier of context
    character(len=:), allocatable :: source
  end type label_type

  interface label_type
    module procedure new_label
  end interface label_type

  !> Definition of diagnostic message
  type :: lox_diagnostic
    !> Level of message
    type(level_enum) :: level
    !> Primary message
    character(len=:), allocatable :: message
    !> Context of the diagnostic source
    character(len=:), allocatable :: source
    !> Messages associated with this diagnostic
    type(label_type), allocatable :: label(:)
    !> Additional diagnostic information
    type(lox_diagnostic), allocatable :: sub(:)
  end type lox_diagnostic

  interface lox_diagnostic
    module procedure new_diagnostic
  end interface lox_diagnostic

  type :: line_token
    integer :: first, last
  end type line_token

  character(len=*), parameter :: nl = new_line('a')

contains

  function new_label(level, text, line, first, last, primary) result(new)
    type(level_enum), intent(in) :: level
    character(len=*), intent(in), optional :: text
    integer, intent(in) :: line, first, last
    logical, intent(in), optional :: primary
    type(label_type) :: new

    if (present(text)) new%text = text
    new%level = level
    new%line = line
    new%first = first
    new%last = last
    if (present(primary)) then
      new%primary = primary
    else
      new%primary = .false.
    end if
  end function new_label

  !> Create new diagnostic message
  function new_diagnostic(level, message, source, label, diagnostic) result(new)
    !> Level of message
    type(level_enum), intent(in) :: level
    !> Primary message
    character(len=*), intent(in), optional :: message
    !> Context of the diagnostic source
    character(len=*), intent(in), optional :: source
    !> Messages associated with this diagnostic
    type(label_type), intent(in), optional :: label(:)
    !> Additional diagnostic information
    type(lox_diagnostic), intent(in), optional :: diagnostic(:)
    type(lox_diagnostic) :: new

    new%level = level
    if (present(message)) new%message = message
    if (present(source)) new%source = source
    if (present(label)) new%label = label
    if (present(diagnostic)) new%sub = diagnostic
  end function new_diagnostic

  pure function line_tokens(input) result(token)
    character(len=*), intent(in) :: input
    type(line_token), allocatable :: token(:)

    integer :: first, last

    first = 1
    last = 0
    allocate(token(0))
    do while (first <= len(input))
      last = index(input(first+1:), nl) + first - 1
      if (last < first) then
        last = len(input)
      end if

      token = [token, line_token(first, last)]

      first = last + (1 + len(nl))
    end do
  end function line_tokens

  pure recursive function render_diagnostic(diag, input, color) result(string)
    character(len=*), intent(in) :: input
    type(lox_diagnostic), intent(in) :: diag
    type(lox_terminal), intent(in) :: color
    character(len=:), allocatable :: string

    integer :: is

    string = &
      render_message(diag%level, diag%message, color)

    if (allocated(diag%label)) then
      string = string // nl // &
        render_text_with_labels(input, diag%label, color, source=diag%source)
    end if

    if (allocated(diag%sub)) then
      do is = 1, size(diag%sub)
        string = string // nl // &
          render_diagnostic(diag%sub(is), input, color)
      end do
    end if

  end function render_diagnostic

  pure function render_message(level, message, color) result(string)
    type(level_enum), intent(in) :: level
    character(len=*), intent(in), optional :: message
    type(lox_terminal), intent(in) :: color
    character(len=:), allocatable :: string

    if (present(message)) then
      string = &
        level_name(level, color) // color%bold // ": " // message // color%reset
    else
      string = &
        level_name(level, color)
    end if
  end function render_message

  pure function level_name(level, color) result(string)
    type(level_enum), intent(in) :: level
    type(lox_terminal), intent(in) :: color
    character(len=:), allocatable :: string

    select case(level%id)
    case(level_error%id)
      string = color%bold_red // "error" // color%reset
    case(level_syntax_error%id, level_eof_error%id)
      string = color%bold_red // "syntax error" // color%reset
    case(level_semantic_error%id)
      string = color%bold_red // "semantic error" // color%reset
    case(level_runtime_error%id)
      string = color%bold_red // "runtime error" // color%reset
    case(level_warning%id)
      string = color%bold_yellow // "warning" // color%reset
    case(level_help%id)
      string = color%bold_cyan // "help" // color%reset
    case(level_note%id)
      string = color%bold_blue // "note" // color%reset
    case(level_info%id)
      string = color%bold_magenta // "info" // color%reset
    case default
      string = color%bold_blue // "unknown" // color%reset
    end select
  end function level_name

  pure function render_source(source, offset, color) result(string)
    character(len=*), intent(in) :: source
    integer, intent(in) :: offset
    type(lox_terminal), intent(in) :: color
    character(len=:), allocatable :: string

    string = &
      & repeat(" ", offset) // color%bold_blue // "-->" // color%reset // " " // source
  end function render_source

  pure function render_text(input, color, source) result(string)
    character(len=*), intent(in) :: input
    type(lox_terminal), intent(in) :: color
    character(len=*), intent(in), optional :: source
    character(len=:), allocatable :: string

    integer :: it, offset
    type(line_token), allocatable :: token(:)

    token = line_tokens(input)
    offset = integer_width(size(token))

    if (present(source)) then
      string = render_source(source, offset, color) // nl // &
        & repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset
    else
      string = &
        & repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset
    end if

    do it = 1, size(token)
      string = string // nl //&
        & render_line(input(token(it)%first:token(it)%last), to_string(it, offset), color)
    end do
    string = string // nl // &
      repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset

  end function render_text

  pure function render_text_with_label(input, label, color, source) result(string)
    character(len=*), intent(in) :: input
    type(label_type), intent(in) :: label
    type(lox_terminal), intent(in) :: color
    character(len=*), intent(in), optional :: source
    character(len=:), allocatable :: string

    integer :: it, offset, first, last
    type(line_token), allocatable :: token(:)

    token = line_tokens(input)
    first = max(1, label%line - 1)
    last = min(size(token), label%line + 1)
    offset = integer_width(last)

    if (present(source)) then
      string = render_source(source, offset, color) // ":" // &
        & to_string(label%line) // ":" // &
        & to_string(label%first) // "-" // to_string(label%last) // nl // &
        & repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset
    else
      string = &
        & repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset
    end if

    do it = first, last
      string = string // nl //&
        & render_line(input(token(it)%first:token(it)%last), &
        &             to_string(it, offset), color)
      if (it == label%line) then
        string = string // nl //&
          & repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset // &
          & render_label(label, color)
      end if
    end do
    string = string // nl // &
      repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset

  end function render_text_with_label

  pure function render_text_with_labels(input, label, color, source) result(string)
    character(len=*), intent(in) :: input
    type(label_type), intent(in) :: label(:)
    type(lox_terminal), intent(in) :: color
    character(len=*), intent(in), optional :: source
    character(len=:), allocatable :: string

    integer :: it, il, offset, first, last
    type(line_token), allocatable :: token(:)
    logical, allocatable :: display(:)

    token = line_tokens(input)
    first = max(1, minval(label%line) - 1)
    last = min(size(token), maxval(label%line) + 1)
    offset = integer_width(last)

    it = 1  ! Without a primary we use the first label
    do il = 1, size(label)
      if (label(il)%primary) then
        it = il
        exit
      end if
    end do

    if (present(source)) then
      string = render_source(source, offset, color) // ":" // &
        & to_string(label(it)%line) // ":" // &
        & to_string(label(it)%first) // "-" // to_string(label(it)%last) // nl // &
        & repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset
    else
      string = &
        & repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset
    end if

    allocate(display(first:last), source=.false.)
    do il = 1, size(label)
      display(max(first, label(il)%line - 1):min(last, label(il)%line + 1)) = .true.
    end do

    do it = first, last
      if (.not.display(it)) then
        if (display(it-1)) then
          string = string // nl //&
            & repeat(" ", offset + 1) // color%bold_blue // ":" // color%reset
        end if
        cycle
      end if

      string = string // nl //&
        & render_line(input(token(it)%first:token(it)%last), &
        &             to_string(it, offset), color)
      if (any(it == label%line)) then
        do il = 1, size(label)
          if (label(il)%line /= it) cycle
          string = string // nl //&
            & repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset // &
            & render_label(label(il), color)
        end do
      end if
    end do
    string = string // nl // &
      repeat(" ", offset + 1) // color%bold_blue // "|" // color%reset

  end function render_text_with_labels

  pure function render_label(label, color) result(string)
    type(label_type), intent(in) :: label
    type(lox_terminal), intent(in) :: color
    character(len=:), allocatable :: string

    integer :: width
    character :: marker
    character(len=:), allocatable :: this_color

    marker = merge("^", "-", label%primary)
    width = label%last - label%first + 1
    this_color = level_color(label%level, color)

    string = &
      & repeat(" ", label%first) // this_color // repeat(marker, width) // color%reset
    if (allocated(label%text)) then
      string = string // &
        & " " // this_color // label%text // color%reset
    end if

  end function render_label

  pure function level_color(level, color) result(this_color)
    type(level_enum), intent(in) :: level
    type(lox_terminal), intent(in) :: color
    character(len=:), allocatable :: this_color

    select case(level%id)
    case(level_error%id, level_syntax_error%id, level_eof_error%id, &
        & level_semantic_error%id, level_runtime_error%id)
      this_color = color%bold_red
    case(level_warning%id)
      this_color = color%bold_yellow
    case(level_help%id)
      this_color = color%bold_cyan
    case(level_info%id)
      this_color = color%bold_magenta
    case default
      this_color = color%bold_blue
    end select
  end function level_color

  pure function render_line(input, line, color) result(string)
    character(len=*), intent(in) :: input
    character(len=*), intent(in) :: line
    type(lox_terminal), intent(in) :: color
    character(len=:), allocatable :: string

    string = &
      & line // " " // color%bold_blue // "|" // color%reset // " " // input
  end function render_line

  pure function integer_width(input) result(width)
    integer, value :: input
    integer :: width

    width = 0
    do while (input /= 0)
      input = input / 10
      width = width + 1
    end do

  end function integer_width

  !> Represent an integer as character sequence.
  pure function to_string(val, width) result(string)
    integer, intent(in) :: val
    integer, intent(in), optional :: width
    character(len=:), allocatable :: string
    integer, parameter :: buffer_len = range(val)+2
    character(len=buffer_len) :: buffer
    integer :: pos
    integer :: n
    character(len=1), parameter :: numbers(0:9) = &
      ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]

    if (val == 0) then
      string = numbers(0)
      return
    end if

    n = abs(val)
    buffer = ""

    pos = buffer_len + 1
    do while (n > 0)
      pos = pos - 1
      buffer(pos:pos) = numbers(mod(n, 10))
      n = n/10
    end do
    if (val < 0) then
      pos = pos - 1
      buffer(pos:pos) = '-'
    end if

    if (present(width)) then
      string = repeat(" ", max(width-(buffer_len+1-pos), 0)) // buffer(pos:)
    else
      string = buffer(pos:)
    end if
  end function to_string

  elemental function op_equal(left, right) result(equal)
    type(level_enum), intent(in) :: left
    type(level_enum), intent(in) :: right
    logical :: equal

    equal = left%id == right%id
  end function op_equal

end module flox_diagnostic

max_stars_repo_name: awvwgk/flox

max_issues_repo_name: awvwgk/flox

max_forks_repo_name: awvwgk/flox


text:
c     Subroutine to get codes for GSOM processing
c     AJ_Kettle, 06Sep2019
c     AJ_Kettle, 10Oct2019: modified to hardwire height obs above ground
c     27May2020: changed snow variable code from 55 to 45

      SUBROUTINE get_codes_gsom_processing20200527(l_varselect,
     +   s_varselect,s_code_observation,s_code_unit,
     +   s_code_value_significance,s_code_unit_original,
     +   s_code_conversion_method,s_code_conversion_flag,
     +   s_predef_numerical_precision,s_predef_hgt_obs_above_sfc)

c************************************************************************
      INTEGER             :: l_varselect

      CHARACTER(LEN=4)    :: s_varselect(l_varselect)
      CHARACTER(LEN=3)    :: s_code_observation(l_varselect)
      CHARACTER(LEN=3)    :: s_code_unit(l_varselect)
      CHARACTER(LEN=3)    :: s_code_value_significance(l_varselect)
      CHARACTER(LEN=3)    :: s_code_unit_original(l_varselect)
      CHARACTER(LEN=3)    :: s_code_conversion_method(l_varselect)
      CHARACTER(LEN=3)    :: s_code_conversion_flag(l_varselect)
      CHARACTER(LEN=10)   :: s_predef_numerical_precision(l_varselect)
      CHARACTER(LEN=10)   :: s_predef_hgt_obs_above_sfc(l_varselect)
c*****
c     Variables used in subroutine

      INTEGER             :: i,j,k,ii,jj,kk
c************************************************************************

      s_varselect(1)  ='TMAX'
      s_varselect(2)  ='TMIN'
      s_varselect(3)  ='TAVG'
      s_varselect(4)  ='PRCP'
      s_varselect(5)  ='SNOW'
      s_varselect(6)  ='AWND'

      s_code_observation(1)='85'
      s_code_observation(2)='85'
      s_code_observation(3)='85'
      s_code_observation(4)='44'
      s_code_observation(5)='45'     !'55'
      s_code_observation(6)='107'

      s_code_unit(1)='005'
      s_code_unit(2)='005'
      s_code_unit(3)='005'
      s_code_unit(4)='710'
      s_code_unit(5)='710'
      s_code_unit(6)='731'

      s_code_value_significance(1)='0'  !MAX
      s_code_value_significance(2)='1'  !MIN
      s_code_value_significance(3)='2'  !MEAN
      s_code_value_significance(4)='13' !accumulation
      s_code_value_significance(5)='13' !accumulation
      s_code_value_significance(6)='2'  !mean

      s_code_unit_original(1)='060'  !deg C
      s_code_unit_original(2)='060'  !deg C
      s_code_unit_original(3)='060'  !deg C
      s_code_unit_original(4)='710'  !mm
      s_code_unit_original(5)='710'  !mm
      s_code_unit_original(6)='731'  !m/s

      s_code_conversion_method(1)='1'
      s_code_conversion_method(2)='1'
      s_code_conversion_method(3)='1'
      s_code_conversion_method(4)=''
      s_code_conversion_method(5)=''
      s_code_conversion_method(6)=''

c     CDM template 21Aug2019: column 20
c     0=both original (non-SI) and converted (SI) values available
c     1=only original value in non-SI units available; no conversion
c     2=original in SI units available; no conversion required
c     3=value coded; see code table
      s_code_conversion_flag(1)  ='0'
      s_code_conversion_flag(2)  ='0'
      s_code_conversion_flag(3)  ='0'
      s_code_conversion_flag(4)  ='2'
      s_code_conversion_flag(5)  ='2'
      s_code_conversion_flag(6)  ='2'

      s_predef_numerical_precision(1)   ='' !'0.1'
      s_predef_numerical_precision(2)   ='' !'0.1'
      s_predef_numerical_precision(3)   ='' !'0.1'
      s_predef_numerical_precision(4)   ='' !'0.1'
      s_predef_numerical_precision(5)   ='' !'0.1'
      s_predef_numerical_precision(6)   ='' !'0.1'

      s_predef_hgt_obs_above_sfc(1)='2'   !TMAX
      s_predef_hgt_obs_above_sfc(2)='2'   !TMIN
      s_predef_hgt_obs_above_sfc(3)='2'   !TAVG
      s_predef_hgt_obs_above_sfc(4)='1'   !PRCP
      s_predef_hgt_obs_above_sfc(5)='0'   !SNOW
      s_predef_hgt_obs_above_sfc(6)='10'  !AWND

c     NOT CHOSEN: EMXT,EMNT,EMXP,EMSN,EMSD
c************************************************************************

      RETURN
      END

ext: f

max_stars_repo_name: glamod/glamod-nuim

max_issues_repo_name: glamod/glamod-nuim

max_forks_repo_name: glamod/glamod-nuim


text:
36 e Legislature, 2 ieme Session
HANSARD REVISE * NUMERO 64
Le mercredi 15 mars 2000
LE DECES DE MARCEL PEPIN
LE BUDGET DU MINISTRE DES FINANCES DU QUEBEC
M. Guy St-Julien
LE BUDGET DU MINISTRE DES FINANCES DU QUEBEC
LES RENDEZ-VOUS DE LA FRANCOPHONIE
LES MINES GIANT DE LA ROYAL OAK
LA FETE NATIONALE DES ACADIENS
Le tres hon. Jean Chretien
Le tres hon. Jean Chretien
Le tres hon. Jean Chretien
Le tres hon. Jean Chretien
L'hon. Pierre S. Pettigrew
L'hon. Ralph E. Goodale
L'hon. Harbance Singh Dhaliwal
Mme Judy Wasylycia-Leis
Mme Judy Wasylycia-Leis
Le tres hon. Jean Chretien
L'hon. George S. Baker
REPONSE DU GOUVERNEMENT A DES PETITIONS
LOI DONNANT EFFET A L'EXIGENCE DE CLARTE FORMULEE PAR LA
Projet de loi C-20. Troisieme lecture
LES COMITES DE LA CHAMBRE
Procedure et affaires de la Chambre
LA LOI DONNANT EFFET A L'EXIGENCE DE CLARTE FORMULEE PAR LA
Projet de loi C-20. Troisieme lecture
LOI SUR LE PROGRAMME DE PROTECTION DES TEMOINS
HANSARD REVISE * NUMERO 64
Le mercredi 15 mars 2000
La seance est ouverte a 14 heures.
Comme le veut l'usage le mercredi, nous chanterons l'hymne national.
Les deputes se levent et chantent l'hymne national.]
LE DECES DE MARCEL PEPIN
M. Yvon Charbonneau (Anjou-Riviere-des-Prairies, Lib.):
En somme, le Quebec a perdu un grand travailleur et un grand syndicaliste.
M. Chuck Cadman (Surrey-Nord, Ref.):
Ils reclament rien de moins qu'une verification judiciaire complete.
Nous savons que 19 enquetes policieres sont actuellement en cours sur le cafouillis gouvernemental.
J'espere que le solliciteur general ecoute.
M. Reg Alcock (Winnipeg-Sud, Lib.):
Elle est decedee le 11 mars a l'hopital Foothills de Calgary.
LE BUDGET DU MINISTRE DES FINANCES DU QUEBEC
M. Guy St-Julien (Abitibi-Baie-James-Nunavik, Lib.):
M. Mauril Belanger (Ottawa-Vanier, Lib.):
L'espece humaine aura donc produit la premiere carte de sa propre formule genetique.
M. Roy Bailey (Souris-Moose Mountain, Ref.):
Dans l'ouest du Canada, il existe une tradition automnale des diners de volaille.
LE BUDGET DU MINISTRE DES FINANCES DU QUEBEC
M. Yvan Loubier (Saint-Hyacinthe-Bagot, BQ):
Cela, on appelle ca la souverainete du Quebec.
M. Gary Pillitteri (Niagara Falls, Lib.):
Nos cadets ont recemment termine des etudes sur le gouvernement canadien et la societe democratique.
M. Rick Casson (Lethbridge, Ref.):
Le depute de Mississauga-Ouest a la parole.
M. Steve Mahoney (Mississauga-Ouest, Lib.):
Ces employes effectuent de longues heures de travail, dans des conditions emotivement harassantes.
Kate O'Brien interview des refugies dans un camp situe dans le desert du Sahara.
Les regles de securite sont tres exigeantes.
Kate expose sa vie tous les jours.
LES RENDEZ-VOUS DE LA FRANCOPHONIE
Mme Raymonde Folco (Laval-Ouest, Lib.):
LES MINES GIANT DE LA ROYAL OAK
M. Pat Martin (Winnipeg-Centre, NPD):
M. Daniel Turp (Beauharnois-Salaberry, BQ):
Le projet de loi C-20 ira rejoindre la Constitution de 1982.
Il n'aura aucune legitimite aux yeux des Quebecoises et Quebecois qui, quoiqu'il arrive...
L'honorable deputee de Beausejour-Petitcodiac a la parole.
LA FETE NATIONALE DES ACADIENS
Mme Angela Vautour (Beausejour-Petitcodiac, PC):
Le 15 aout est la fete nationale des Acadiens et Acadiennes de ce pays.
Mme Deborah Grey (Edmonton-Nord, Ref.):
Je prierais aujourd'hui les deputes de mesurer leurs propos.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Le Parti reformiste ne s'interesse aucunement aux faits, mais revoyons-les encore une fois.
Mme Deborah Grey (Edmonton-Nord, Ref.):
On leur a dit de faire fi des regles.
On leur a dit de ne pas se preoccuper de details comme la loi.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Monsieur le President, nous n'enfreignons pas la loi.
Mme Deborah Grey (Edmonton-Nord, Ref.):
Monsieur le President, ce n'est la que l'opinion d'une seule fille.
Je voudrais citer ce qu'ont dit ses propres employes.
Je prefererais, mes collegues, que nous nous appelions par nos titres.
C'est quelque chose qui vient du gouvernement, et j'aimerais citer ce document verbatim.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Monsieur le President, cette fille repondra de la meme facon...
Monsieur le President, regardons les faits.
Nous avons determine que nous avions des ameliorations administratives a apporter dans mon ministere.
Nous mettons en oeuvre un plan en six points.
Mme Diane Ablonczy (Calgary-Nose Hill, Ref.):
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Mme Diane Ablonczy (Calgary-Nose Hill, Ref.):
Cela est interdit par la loi.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Nous allons respecter les criteres du Conseil du Tresor.
M. Gilles Duceppe (Laurier-Sainte-Marie, BQ):
Le tres hon. Jean Chretien (premier ministre, Lib.):
M. Gilles Duceppe (Laurier-Sainte-Marie, BQ):
Monsieur le President, on parle un peu plus que de consultations.
Le tres hon. Jean Chretien (premier ministre, Lib.):
M. Michel Gauthier (Roberval, BQ):
Le tres hon. Jean Chretien (premier ministre, Lib.):
Il y a une loi sur les lobbyistes.
M. Michel Gauthier (Roberval, BQ):
Comment peut-il dire cela?
Le tres hon. Jean Chretien (premier ministre, Lib.):
Monsieur le President, il a agi a une ou deux reprises...
Il n'a jamais ete paye par le gouvernement canadien, par mon Bureau, pour agir.
C'est sa profession de le faire.
Mme Alexa McDonough (Halifax, NPD):
Monsieur le President, ma question s'adresse au premier ministre.
L'hon. John Manley (ministre de l'Industrie, Lib.):
Il y a des questions qui sont deja devant les tribunaux.
Mme Alexa McDonough (Halifax, NPD):
Le ministre du Commerce international a la parole.
L'hon. Pierre S. Pettigrew (ministre du Commerce international, Lib.):
M. Scott Brison (Kings-Hants, PC):
Monsieur le President, ma question s'adresse au ministre des Finances.
L'hon. Paul Martin (ministre des Finances, Lib.):
Monsieur le President, je suis tres heureux de voir le depute.
M. Scott Brison (Kings-Hants, PC):
Monsieur le President, moi au moins, je reconnais mes erreurs.
Le ministre essaie lui de les camoufler.
Le fait est que la decision a ete prise.
L'hon. Paul Martin (ministre des Finances, Lib.):
M. Monte Solberg (Medicine Hat, Ref.):
L'avis de la ministre ne compte guere dans une situation comme celle-la.
Je veux savoir si la ministre a renvoye la question a la GRC.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
C'est un fait.
Ce sont la les faits, et voila ce qu'il en est.
M. Monte Solberg (Medicine Hat, Ref.):
La ministre a dit qu'il n'en est rien.
La ministre a-t-elle renvoye la question a la GRC?
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
M. Paul Crete (Kamouraska-Riviere-du-Loup-Temiscouata-Les Basques, BQ):
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
M. Paul Crete (Kamouraska-Riviere-du-Loup-Temiscouata-Les Basques, BQ):
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
M. Grant McNally (Dewdney-Alouette, Ref.):
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Aujourd'hui, ils les defendent.
Vont-ils se faire une idee?
M. Grant McNally (Dewdney-Alouette, Ref.):
Le ministere qu'elle dirige n'a pas observe la loi.
Il a fallu ordonner a ses employes de commencer a le faire.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Monsieur le President, encore une fois, je serai tres claire.
Nous en avons fait une priorite pour le ministere.
Mme Christiane Gagnon (Quebec, BQ):
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Monsieur le President, ce n'est pas du tout ce que les fonctionnaires ont dit.
Mme Christiane Gagnon (Quebec, BQ):
Monsieur le President, la ministre et ses fonctionnaires se contredisent formellement.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
M. Rob Anders (Calgary-Ouest, Ref.):
La serie de questions et de reponses du ministere...
Veuillez bien choisir vos mots.
Le depute de Calgary-Ouest a la parole.
Comment la ministre a-t-elle pu penser qu'elle pouvait enfreindre la loi...
D'apres ce que j'ai entendu, la question est recevable.
La ministre du Developpement des ressources humaines a la parole.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Monsieur le President, encore une fois, je rejette categoriquement les allegations du depute.
M. Rob Anders (Calgary-Ouest, Ref.):
Nous decouvrons maintenant que cela s'est fait en grande partie illegalement.
Pourquoi les liberaux pensent-ils etre...
La question est irrecevable.
Le depute de Temiscamingue a la parole.
M. Pierre Brien (Temiscamingue, BQ):
Ma question s'adresse au premier ministre.
M. Charles Hubbard (Miramichi, Lib.):
Le ministre pourrait-il nous dire comment vont les exportations de poisson?
Les deputes de l'autre cote ont besoin de beaucoup de produits du poisson.
Ce serait bon pour eux et ca les aiderait a developper leur cerveau.
L'hon. Harbance Singh Dhaliwal (ministre des Peches et des Oceans, Lib.):
M. Ted White (North Vancouver, Ref.):
Pourquoi la direction ne se fait-elle pas une idee?
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Monsieur le President, les affirmations du depute sont de nouveaux inexactes.
Je sais qu'il est partisan d'une vigoureuse administration publique.
M. Ted White (North Vancouver, Ref.):
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
Monsieur le President, cette affirmation est de nouveau totalement inexacte.
Les faits sont les suivants.
Le plan est deja en oeuvre.
Nous ameliorons notre systeme afin de mieux servir les Canadiens.
Mme Judy Wasylycia-Leis (Winnipeg-Centre-Nord, NPD):
Le ministre federal de la Sante avait declare que le gouvernement etudiait la question.
Le 13 decembre, le ministre provincial confirmait les intentions de son gouvernement.
Le ministre federal a declare a la Chambre des communes qu'il etudiait la question.
Le 2 mars, le projet de loi 11 a ete presente.
L'hon. Allan Rock (ministre de la Sante, Lib.):
Mme Judy Wasylycia-Leis (Winnipeg-Centre-Nord, NPD):
Les Canadiens veulent une reponse.
Va-t-il dire aux Canadiens quand precisement il entend terminer son analyse.
Va-t-il s'opposer au projet de Ralph Klein?
L'hon. Allan Rock (ministre de la Sante, Lib.):
M. Jean Dube (Madawaska-Restigouche, PC):
Monsieur le President, Rene Fugere entretient des liens etroits avec le premier ministre.
Il a represente celui-ci lors d'evenements.
Le tres hon. Jean Chretien (premier ministre, Lib.):
Monsieur le President, beaucoup de gens au Canada connaissent Jean Chretien.
J'ai ete elu a 11 reprises dans Saint-Maurice.
Je suis depute de cette circonscription depuis 1963.
Je leur suis reconnaissant de m'avoir elu a maintes reprises.
M. Jean Dube (Madawaska-Restigouche, PC):
Fugere n'etait pas inscrit sur la liste des lobbyistes.
L'hon. John Manley (ministre de l'Industrie, Lib.):
Si elles ne l'ont pas ete, les mesures appropriees seront prises.
M. Lynn Myers (Waterloo-Wellington, Lib.):
Entre autres, ils font les frais de la politique de recouvrement des couts.
L'hon. Lyle Vanclief (ministre de l'Agriculture et de l'Agroalimentaire, Lib.):
Monsieur le President, je suis heureux que le depute ait pose cette question.
Elle me permet de rappeler a tous que le gouvernement a l'agriculture a coeur.
M. Bob Mills (Red Deer, Ref.):
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
M. Ghislain Lebel (Chambly, BQ):
Ma question s'adresse au premier ministre.
L'hon. Jane Stewart (ministre du Developpement des ressources humaines, Lib.):
On a recommande au ministere de fermer le fonds fiduciaire.
Mme Michelle Dockrill (Bras d'Or-Cape Breton, NPD):
Les seuls qui sont dephases sont les deputes neo-democrates.
Quand vont-ils s'accorder avec leurs electeurs?
M. Bill Casey (Cumberland-Colchester, PC):
Monsieur le President, ma question s'adresse au ministre de l'Industrie.
L'hon. John Manley (ministre de l'Industrie, Lib.):
Cela equivaut a creer deux MIT virtuels au Canada.
C'est ainsi que le Canada saura affronter la concurrence au XXIe siecle.
REPONSE DU GOUVERNEMENT A DES PETITIONS
M. Gar Knutson (secretaire parlementaire du premier ministre, Lib.):
Que la Chambre passe maintenant a l'ordre du jour.
Le depute de Roberval a la parole pour un rappel au Reglement.
M. Michel Gauthier (Roberval, BQ):
Je suis heureux de le voir ici aujourd'hui.
Son recours au Reglement est certainement tres serieux.
La motion a ete presentee et nous devons la considerer.
Monsieur le President, me permettez-vous de vous poser une question?
J'ai un grand respect pour l'honorable depute de Roberval.
Nous sommes maintenant rendus a l'etape des affaires courantes ordinaires.
M. Gilles Duceppe (Laurier-Sainte-Marie, BQ):
Je vais mettre la question aux voix.
Plait-il a la Chambre d'adopter la motion?
Que tous ceux qui sont en faveur de la motion veuillent bien dire oui.
Que tous ceux qui sont contre veuillent bien dire non.
A mon avis, les oui l'emportent.
Et plus de cinq deputes s'etant leves:
(La motion, mise aux voix, est adoptee.)
Je declare la motion adoptee.
Les Quebecois ne veulent pas de cette perspective inquietante.
Le projet de loi de la clarte est pro-Quebecois, pro-democratie.
Je cite M. Hogg:
L'ancien premier ministre de l'Ontario, Bob Rae, a declare:
Alors, on n'est pas si loin d'etre d'accord.
Les electeurs les presseraient de repondre et ils auraient bien raison.
Ils auraient droit a cette information.
Les chefs independantistes feraient mieux de viser la plus grande clarte.
Avec la clarte, tout le monde gagne.
Parlons maintenant de la clarte de la majorite.
Il y consacre sa vie.
Or, voici ce qu'il a declare devant le comite legislatif:
Les dirigeants independantistes vont-ils qualifier M. Broadbent d'antidemocrate?
Faut-il le declarer antidemocrate lui aussi?
Le projet de loi sur la clarte, comme chacun sait, ne fixe pas de seuil.
Comme le doyen Hogg l'a dit au comite:
Voila pour la clarte de la majorite.
Maintenant je vais traiter de la question autochtone.
Deux poids, deux mesures.
J'insiste sur le mot notamment.
Fini le temps de l'ambiguite.
Monsieur le President, j'invoque le Reglement.
Le president suppleant (M. McClelland):
Le depute a t-il le consentement unanime de la Chambre pour presenter la motion?
M. Grant Hill (Macleod, Ref.):
L'opposition officielle est d'accord sur le fait que la question doit etre claire.
Nous avons tente de determiner ce que serait la majorite necessaire.
Nous estimons que le mieux serait de mener une vaste consultation.
Je voudrais donner aujourd'hui notre evaluation du respect de ces grands principes.
C'etait une question a deux volets.
Lui aussi etait d'avis que la question n'etait pas claire.
Elle etait loin d'etre claire.
Ce projet de loi aboutira a une question claire.
Qu'en est-il de la majorite?
Je dirais que nous avons echoue sur cette question.
J'avoue que ces arguments etaient parfois convaincants.
Il s'agissait d'un seuil assez faible.
En 1786, le Massachusetts voulait l'independance et a decide de se separer du Maine.
Il s'agissait d'un Etat.
Le Maine etait un district.
Le Massachusetts voulait devenir un Etat.
Le troisieme principe concerne les consultations larges.
Nous avons echoue la-dessus egalement.
Nous n'avons pas pu parcourir le pays.
Il n'y a eu qu'une seule semaine d'audiences du comite.
De nombreux temoins n'ont pas pu y assister.
Nous avons gagne une chose, soit la telediffusion des deliberations.
Toutes ces questions auraient au moins pu etre l'objet de discussions.
Nous aurions prevu des consultations plus larges.
Il y aurait eu un plus grand nombre de questions examinees.
J'ai mentionne ces questions.
Notre projet de loi n'aurait pas ete proclame.
Dans notre projet de loi, la majorite aurait ete de 50 p. 100 plus un.
C'est une critique legitime.
Bref, l'opposition officielle va continuer d'appuyer ce projet de loi.
J'ai mentionne des points qui auraient pu etre ameliores.
Je dis simplement ceci aux Quebecois:
Qui a peur d'une question claire?
M. Daniel Turp (Beauharnois-Salaberry, BQ):
Le projet de loi C-20 est antidemocratique.
Nous le repeterons sans cesse.
Ce n'est pas de cela dont il s'agit.
Ils ne se respectent pas.
Mais ce sentiment n'est pas partage.
Ils votent pour des leaders independantistes et leur donnent leur confiance.
La regle du 50 p. 100 plus un est une regle acceptable et acceptee.
C'est une regle universellement appliquee.
La regle du 50 p. 100 plus un est la regle universellement acceptee.
Ce n'etait pas clair.
Le non des Quebecois en 1980 et en 1995 n'etait pas clair.
C'est drole, n'est-ce pas?
La seule confusion qui existerait serait dans le camp des souverainistes.
En 1997, il n'a fait elire que 26 deputes dans cette Chambre.
Le Parti liberal du Canada ne represente pas les Quebecois.
Non, le comite ne devait pas voyager.
Il devait se limiter a entendre 45 temoins ici.
De quoi avait peur le ministre?
Non, il n'a pas voulu avoir le courage de ses convictions.
Non, il fallait limiter les debats.
Il fallait, en fait, faire des travaux de ce comite des travaux tres partisans.
Ils disaient: Il faudrait un consensus pour organiser un referendum sur la souverainete.
Le ministre le sait.
La societe civile du Quebec est clairement opposee a ce projet de loi.
Ce projet de loi sera denue de legitimite.
Il n'empechera pas le Quebec de decider de son avenir.
Le debat ne se terminera pas ici.
En conclusion, vous me permettrez de dire ceci au nom des deputes du Bloc quebecois.
Nous, deputes du Bloc quebecois, affirmons que la nation quebecoise est souveraine.
Nous, deputes du Bloc quebecois, affirmons que le Quebec est libre.
LES COMITES DE LA CHAMBRE
PROCEDURE ET AFFAIRES DE LA CHAMBRE
M. Dale Johnston (Wetaskiwin, Ref.):
Monsieur le President, j'invoque le Reglement.
Le president suppleant (M. McClelland):
Y a-t-il consentement unanime?
Le president suppleant (M. McClelland):
Plait-il a la Chambre d'adopter la motion?
M. Bill Blaikie (Winnipeg-Transcona, NPD):
M. Bob Kilger (Stormont-Dundas-Charlottenburgh, Lib.):
Monsieur le President, j'invoque le Reglement.
Le president suppleant (M. McClelland):
Le whip en chef du gouvernement a-t-il le consentement unanime?
Est-ce que cela s'applique aux deux?
Le president suppleant (M. McClelland):
Je disais donc que plusieurs aspects de ce projet de loi nous preoccupent.
Cependant, le gouvernement a rejete ces amendements pour des motifs qui lui sont propres.
Nous sommes egalement preoccupes par le role du Senat.
Nous avons propose des amendements a cet egard, mais ils ont ete rejetes.
Nous avons travaille sur ces amendements tout au long du processus.
Je pourrais dire que ma colere etait justifiee.
Deux de nos amendements ont en fait ete acceptes.
C'etait des amendements importants.
Ce n'est pas une decision qui a ete facile.
A mon avis, le projet de loi C-20 satisfait a ce critere.
Nous ne pouvons pas en venir a cela de facon innocente.
Il existe un moyen legitime de realiser l'autodetermination et la secession.
J'espere que nous n'en viendrons jamais a cela.
J'exhorte cependant le gouvernement a se decider a prevoir son propre plan A.
C'est a mon avis ce que prevoit le projet de loi C-20.
Nous sommes fort mecontents de la facon dont on a procede jusqu'a ce jour.
M. Andre Bachand (Richmond-Arthabaska, PC):
Le projet de loi C-20 a ete extremement difficile, frustrant, derangeant et alarmant.
C'est ce qu'on vient de faire.
Mais apres le projet de loi C-20, que se passera-t-il?
Ce sera la periode latente du gouvernement.
Tout va etre regle, et il n'y aura pas de changements.
Je le dis souvent, un pays evolue au meme rythme que ses habitants.
Il faut absolument que les lois evoluent egalement.
Mais le gouvernement ne bouge pas ou pratiquement pas.
On ne fait rien.
On dit: On ne veut pas en parler.
C'est une fausse zone de confort, une fausse zone de securite.
C'est quoi la logique la-dedans?
C'est une logique politique.
Les sondages demontrent que tout le monde veut une question claire et une majorite claire.
Ce n'est pas ce qu'on fait.
Mais le projet de loi n'est pas clair.
La question est-elle claire?
Ils ne comprennent pas.
Est-ce qu'il va y avoir une guerre de juristes?
Et il s'agissait de 91 p. 100.
On peut constater a quel point la logique de la majorite ne tient pas.
Vous voyez, cela ne tient pas.
C'est cela, le projet de loi C-20, cela ne tient pas debout.
Peut-on imaginer a quel point c'est illogique?
Oui, mais il y a un autre referendum.
Un pays, ce n'est pas un contrat de mariage.
Qu'est-ce qu'un contrat de mariage?
C'est un contrat de divorce.
Ce n'est pas cela, un pays.
Il faut s'assurer qu'on ait un signal.
Cela fait sept ans que le gouvernement est en place.
On est passes de l'indifference au fouet.
Il ne l'a pas ouvert beaucoup.
Mais quel message lance-t-on?
Ils disent: Il fallait faire quelque chose.
La commande est la.
Dire cela, ce n'est pas fort.
Pourquoi ne pas avoir un projet collectif?
Mais ce n'est pas ce qu'il faut faire.
Apres sept ans, il n'y a rien.
On est passes de l'indifference au fouet.
Ce n'est pas ce que la Cour supreme dit.
Le NPD a propose un amendement concernant les premieres nations.
Il a repondu: Non, il est parfait ce projet de loi.
Le depute de Winnipeg-Transcona a du faire des crises.
Est-ce que c'est cela le message qu'on envoie aux premieres nations?
A leur place, j'aurais peur.
J'aurais toutefois des inquietudes pour la premiere.
Les provinces, malheureusement, laissent le grand frere federal decider completement ce qu'il veut.
Vous etes tellement bon.
Depuis sept ans, vous avez fait des choses.
Ils n'ont pas de projet.
Ils n'ont absolument rien.
La position du parti n'a pas change.
Il y a des deputes qui vont appuyer le gouvernement sur cette question.
On a tente d'expliquer notre position.
L'autre place qui a ete oubliee.
Le president suppleant (M. McClelland):
L'amendement est recevable.
La mise au voix porte sur l'amendement.
Plait-il a la Chambre d'adopter l'amendement?
Le president suppleant (M. McClelland):
Que tous ceux qui sont en faveur de l'amendement veuillent bien dire oui.
Le president suppleant (M. McClelland):
Que tous ceux qui s'y opposent veuillent bien dire non.
Le president suppleant (M. McClelland):
A mon avis, les non l'emportent.
Et plus de cinq deputes s'etant leves:
Le president suppleant (M. McClelland):
(L'amendement, mis aux voix, est rejete.)
Monsieur le President, j'invoque le Reglement.
Que les autres deputes qui ont vote a deux reprises s'identifient.
Monsieur le President, j'invoque le Reglement.
Au nom de la clarte, j'ai moi-meme vote en faveur de l'amendement.
Je declare l'amendement rejete.
Le prochain vote porte sur la motion principale.
(La motion, mise aux voix, est adoptee.)
Je declare la motion adoptee.
(Le projet de loi, lu pour la troisieme fois, est adopte.)
LOI SUR LE PROGRAMME DE PROTECTION DES TEMOINS ET DES CONJOINTS
Le president suppleant (M. McClelland):
Il reste huit minutes au depute de Calgary-Centre.
M. Eric Lowther (Calgary-Centre, Ref.):
Il a ete elabore par des bureaucrates bien intentionnes.
Il n'a aucun veritable mandat.
Il n'a aucun financement, en fait.
Il est difficile de s'informer a son sujet et d'y avoir acces.
Vraiment, il a une application tres limitee.
Sally a quatre enfants.
Ca a ete une histoire tragique.
Finalement, des accusations ont ete portees.
L'individu a ete en liberte surveillee pendant un moment.
Elle s'est adressee aux autorites.
Pendant ce temps, elle a connu une certaine tranquillite d'esprit.
Il est indispensable que nous presentions ce genre de mesure legislative.
Entre 1977 et 1996, 2 048 personnes ont ete tuees par un conjoint au Canada.
Dans 56 p. 100 des cas, la police savait qu'il y avait un probleme.
C'est le cas justement de Sally, dont j'ai parle.
Heureusement, elle est toujours en vie.
Elles pourraient en faire la demande.
A ce moment-la, elles assumeraient une nouvelle identite et pourraient etre domiciliees ailleurs.
Mme Pierrette Venne (Saint-Bruno-Saint-Hubert, BQ):
On le sait, ce sont elles qui, en majorite, sont les victimes.
La violence a souvent lieu dans l'intimite d'une relation.
Il arrive souvent qu'elles soient pourchassees et parfois meme abattues.
Cependant, on constate que malgre ces mesures, des tragedies surviennent encore trop souvent.
Malheureusement, ce programme semble peu connu des femmes et des policiers.
En outre, l'aide offerte y est tres limitee.
Ce programme n'a pas de mandat precis et aucun fondement legislatif ni reglementaire.
Pour toutes ces raisons il apparait nettement insuffisant pour assurer la protection des personnes menacees.
C'est ce qui existe actuellement.
Comme l'indique le texte de la loi, et je cite:
Il s'agit en somme d'une aide complete.
Elles devraient donc pouvoir beneficier des fondements legislatifs et reglementaires de ces programmes.
Il prendrait aussi en consideration un critere plus subjectif.
Enfin, il tiendra compte des autres formes de protection possibles a l'exterieur du programme.
Le Bloc quebecois appuie le projet de loi C-223.
M. Lynn Myers (Waterloo-Wellington, Lib.):
J'ai une longue experience de ce genre de question.
Je felicite le depute qui a pris l'initiative de presenter ce projet de loi.
Nous, les deputes, sommes tous preoccupes par cette question tres grave.
Pour cette raison, cette forme de violence est beaucoup plus repandue qu'elle le devrait.
Parfois, le changement d'identite est le seul recours possible.
C'est loin d'etre la solution ideale.
Ce programme est administre par la police pour des considerations d'ordre policier.
Les enseignements tires de cette experience ont ete precieux.
Un changement d'identite offre assurement une solution de dernier recours.
Au debut, les cas n'etaient pas tres nombreux.
Des consultations ont debute dans ce domaine tres important.
M. Jean Dube (Madawaska-Restigouche, PC):
Malheureusement, ces victimes ne peuvent pas rester anonymes et leur conjoint finit par les retrouver.
Cela aboutit souvent a des actes de violence.
Le Parti progressiste-conservateur appuie ce projet de loi.
Nous nous rejouissons du changement qui consiste a elargir le mandat.
M. Grant McNally (Dewdney-Alouette, Ref.):
Monsieur le President, je suis ravi de participer a ce debat.
Il a explique cela dans son allocution, dans la periode de debat precedente.
Cette situation a attire son attention.
Le besoin etait criant.
Il a appuye dans une certaine mesure le principe de ce projet de loi.
Il presente la des solutions inacceptables pour repondre a un besoin tres serieux.
Il est bien pense.
Il permet une certaine marge de manoeuvre.
C'est tout a fait inacceptable.
Des personnes qui sont brutalisees par leur conjoint seront assassinees par celui-ci.
C'est une triste situation.
Ils doivent souvent s'occuper de situations semblables.
Le projet de loi permettra de sauver des vies.
Cette approche ne fonctionnera pas.
Il s'agit parfois de sujets abstraits.
Il s'agit d'une chose tres simple a faire.
Pourquoi attendre plus longtemps?
Chaque annee qui passe emporte avec elle une centaine de meurtres.
Nous aurions tort de devenir les complices de ces meurtres par notre inactivite.
Apportons une solution positive a un tres serieux probleme.
M. Mike Scott (Skeena, Ref.):
Je suis tres heureux d'apporter mon soutien au projet de loi.
L'appuyer n'est pas seulement important, c'est essentiel.
Chaque semaine, deux Canadiens, presque toujours des femmes, sont assassines par leur conjoint.
Pourquoi ne ressentons-nous pas le besoin de nous attaquer a cette situation?
J'ai ecoute le depute liberal parler un peu plus tot.
Il a laisse entendre que nous adoptions une mauvaise approche.
Je pense que les Canadiens devraient faire comme Bill Clinton: ne pas inhaler.
Certains pourraient pretendre que c'est une mesure couteuse.
N'oublions pas qu'il est question de deux personnes par semaine.
Elle a mis un terme a cette relation.
L'homme a ete emprisonne pendant 18 mois.
Elle a fait ce qu'elle etait censee faire.
Que dois-je faire?
Tammy a envisage longuement de disparaitre de la circulation.
Ce projet de loi leur donnerait un choix, une porte de sortie.
Cette mesure les protegerait.
Il vise a sauver la vie de Canadiens et surtout la vie de femmes canadiennes.
On peut le faire.
Ce projet de loi nous donne les outils requis.
Protegeons la vie de Canadiens.
M. Jim Abbott (Kootenay-Columbia, Ref.):
Monsieur le President, le debat devrait etre denue de sectarisme.
A l'evidence, la question est exceptionnellement grave et depasse la problematique homme-femme.
Elle interesse toutes les regions et toutes les categories de la population.
Nous l'avons pourtant traite avec respect.
Celles-ci ont ete particulierement revelatrices.
Les femmes ne sont pas seules en cause; les enfants aussi en souffrent.
Il est possible de faire encore mieux, mais il est inutile de reinventer la roue.
Il suffit de faire fond sur ce qui existe deja.
Il reste encore un certain nombre de questions a regler.
Le president suppleant (M. McClelland):
La periode reservee a l'etude des initiatives parlementaires est maintenant ecoulee.
(La seance est levee a 19 h 32.)


text:
Gus Lee is the only Americanborn member of a Shanghai family.  He grew up in San Francisco and attended West Point for three years until his failing performance in then mandatory electrical engineering gave him the involuntary opportunity to become an elisted man.  After receiving his School of Law law degree from the University of California at Davis, he rejoined the army as Captain Lee and served as general counsel.  He resumed civilian life to become a deputy district attorney in Sacramento, then served for some years as Director of Attorney Education for the State Bar of California.  He is married and lives with his wife and two children in Colorado Springs.  China Boy is his first novel.

(Taken from the inside jacket of China Boy)

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
*----------------------------------------------------------------------*
      pure function rename_tensor(string, rank, nops, itf_names)
*----------------------------------------------------------------------*
!     Rename tensor according to taste
!     This should be expanded to rename all tensors so they correspond
!     with the ITF algo file
*----------------------------------------------------------------------*

      implicit none
      include 'stdunit.h'
      include 'opdim.h'
      include 'def_contraction.h'
      include 'def_itf_contr.h'

      character(len=MAXLEN_BC_LABEL), intent(in) ::
     &    string
      integer, intent(in) ::
     &    rank,          ! Rank of tensor
     &    nops(ngastp)   ! Number of creation/annhilation ops per excitation space
      type(tensor_names), intent(in) ::
     &     itf_names            ! contains renaming information
      character(len=MAXLEN_BC_LABEL) ::
     &     rename_tensor

      logical ::
     &     found
      integer ::
     &     ii

      found = .false.
      do ii = 1, itf_names%nrename
        if (trim(string)==trim(itf_names%gc_itf_rename(1,ii))) then
          found = .true.
          select case(itf_names%rename_type(ii))
          case(RENAME_BASIC)
            rename_tensor = trim(itf_names%gc_itf_rename(2,ii))
          case(RENAME_HAMILTONIAN)
            if (rank==2) then
              rename_tensor='f'
            else
              if (nops(2)==3) then
                rename_tensor='J' ! Currently use J:eeec for 3 external integrals
              else
                rename_tensor='K'
              end if
            end if
          case(RENAME_ADD_RANK)
            if (rank>18) then
              !write(lulog,*) 'rank = ',rank
              rename_tensor='ERROR_unexp_lg_rank'
            end if
            write(rename_tensor,'(a,i1)')
     &           trim(itf_names%gc_itf_rename(2,ii)),rank/2
          case default
            !write(lulog,*) 'case ',itf_names%rename_type
            rename_tensor='ERROR_unknown_case'
          end select
          exit
        end if
      end do

      if (.not.found) rename_tensor = trim(string)

      if (rename_tensor(1:1)=='_') rename_tensor(1:1)=''

      end function

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


program main
    use iso_c_binding
    implicit none
    include "fftw3.f03" ! FFTW3 est une librairie. Voir www.fftw.org
    integer :: nx, nfft
    integer, parameter :: nxmax=256
    integer, parameter :: mykind=c_double
    real(mykind), pointer, contiguous :: tablein(:,:,:)
    real(c_double) :: t0,t1
    complex(mykind), pointer, contiguous :: tableout(:,:,:)
    type(c_ptr) :: fftwplan
    real(mykind), target :: bigin(nxmax,nxmax,nxmax)
    complex(mykind), target :: bigout(nxmax/2+1,nxmax,nxmax)
    integer :: i
    open(11,file='planingtime')
    open(10,file='ffttime')
    ! look at http://www.fftw.org/doc/Planner-Flags.html
    do nx=2,nxmax ! size of the fft in each direction
        print*,"n=",nx ! size of the fft in each direction
        tablein => bigin(1:nx,1:nx,1:nx)
        tableout => bigout(1:nx,1:nx,1:nx)
        tablein = 0.
        tableout=cmplx(0.,0.)
        call cpu_time(t0) ! timing the planer
        call dfftw_plan_dft_r2c_3d( fftwplan, nx, nx, nx, tablein, tableout, FFTW_ESTIMATE) ! see http://www.fftw.org/doc/Planner-Flags.html
        call cpu_time(t1)
        print*,"It took me",t1-t0,"seconds to optimize FFTW3 to your hardware for this kind of real to complex."
        write(11,*) nx, t1-t0
        tablein = 0
        tableout = 0
        call cpu_time(t0)
        nfft = 10
        print*,"C'est parti pour",nfft," FFT de reel à complex de",nx,"^3"
        do i=1,nfft
            call dfftw_execute( fftwplan )
        end do
        call cpu_time(t1)
        print*,"It took me",(t1-t0)/real(nfft,c_double),"seconds per FFT real to complex of size",nx,"^3"
        print*,
        write(10,*) nx, (t1-t0)/real(nfft,c_double)
        call dfftw_destroy_plan( fftwplan )
    end do
end program main


text:
program f90_cnst_103
	type drv
		real,dimension(10)::r
	end type
	type(drv),target::w
	w%r = (/(real(i),i=1,10)/)
	!!t1 = drv1(itarget,w%r,ltarget(2:10:2))
	!t3(5)%ra = (/(real(i),i=1,10)/)
	end

max_stars_repo_name: xevolver/xevxml

max_issues_repo_name: xevolver/xevxml

max_forks_repo_name: xevolver/xevxml


text:
	SUBROUTINE TM_PROM  ( messg, pagflg, newlin, iret )
C************************************************************************
C* TM_PROM								*
C*									*
C* This subroutine writes a message to the user's terminal followed	*
C* by the phrase 'or type EXIT'.  The phrase '<CR> to page' may also	*
C* be added.  This subroutine does not wait for a user response.	*
C*									*
C* TM_PROM  ( MESSG, PAGFLG, NEWLIN, IRET )				*
C*									*
C* Input parameters:							*
C*	MESSG		CHAR*		Message 			*
C*	PAGFLG		LOGICAL		Flag to add '<CR> to page'	*
C*	NEWLIN		LOGICAL		Flag to move to new line	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return 		*
C**									*
C* Log:									*
C* I. Graffman/RDS	 4/84	Original source code			*
C* M. desJardins/GSFC	 3/88	Cleaned up				*
C* M. desJardins/GSFC	 9/90	Change message for null length string	*
C* K. Brill/NMC		01/92	Call TM_WLIN				*
C************************************************************************
	CHARACTER*(*)	messg
	LOGICAL		pagflg, newlin
C*
	CHARACTER	out*80
C*
	CHARACTER*(*)	strex, strpg
	PARAMETER	( strex = ' or type EXIT:' )
	PARAMETER	( strpg = ', <CR> to page' )
C------------------------------------------------------------------------
	iret= 0
	CALL ST_LSTR  ( messg, length, ierr )
C
C*	Check pagflg to see if page string should be added.
C
	IF  ( pagflg )  THEN
	    IF  ( length .gt. 0 )  THEN
		out = messg ( 1 : length ) // strpg // strex
	      ELSE
		out = 'Enter <CR> to page' // strex
	    END IF
C
C*	    Otherwise, add exit message only.
C
	  ELSE
	    IF  ( length .gt. 0 )  THEN
		out = messg ( 1 : length ) // strex
	      ELSE
		out = 'Type EXIT:'
	    END IF
	END IF
C
C*	Write the output string.
C
	CALL TM_WLIN ( out, newlin, ier )
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
        LOGICAL FUNCTION CKFILE3( FID )  RESULT( CKFLAG )

C***********************************************************************
C Version "$Id: ckfile3.f 1 2017-06-10 18:05:20Z coats $"
C BAMS/MCNC/EDSS/Models-3 I/O API.
C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr.,
C (C) 2003-2011 Baron Advanced Meteorological Systems, and
C (C) 2015 UNC Institute for the Environment
C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
C See file "LGPL.txt" for conditions of use.
C.........................................................................
C  function body starts at line  92
C
C  RETURNS:
C       If environment variable IOAPI_CHECK_HEADERS begins with 'Y' or 'y',
C       checks whether file attributes in FDESC3.EXT commons fit into
C       standard valid ranges, and returns TRUE or FALSE accordingly.
C       Returns TRUE otherwise.
C
C  PRECONDITIONS REQUIRED:
C       FDESC3.EXT commons set by user
C
C  SUBROUTINES AND FUNCTIONS CALLED:
C       m3err()
C
C  REVISION  HISTORY:
C       Prototype 9/95 by CJC
C       Modified  2/97 by CJC:  check for legality of variable-names
C       Modified  3/04 by D.Yin: add check for POLGRD3
C       Modified  6/06 by CJC: modification to support WRF vertical
C       coordinates, from Tanya Otte
C       Modified 03/2010 by CJC: F9x changes for I/O API v3.1
C       Bug-fix  04/2011 in format 94030  from Matt Turner, UC Boulder.
C       Modified 02/2015 by CJC for I/O API 3.2: Support for M3INT8.
C       USE M3UTILIO
C       Modified 07-08/2015 by CJC:  bug reported by Mogesh Naidoo:
C       Add support for EQMGRD3, TRMGRD3, ALBGRD3, LEQGRD3, SINIGRD3.
C       Eliminate unused NETCDF.EXT.  MPIGRD3 type for MPI/PnetCDF
C       distributed I/O
C       Modified 07-05/2016 by CJC:  bugs reported by Edward Anderson,
C       Lockheed Martin,
C***********************************************************************

        USE M3UTILIO

        IMPLICIT NONE

C...........   INCLUDES:

        INCLUDE 'STATE3.EXT'

C...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT( IN ) :: FID     !  subscript for STATE3 arrays

C...........   EXTERNAL FUNCTIONS and their descriptions:

        LOGICAL, EXTERNAL :: CKNAME     !  checks legality of variable-names

C...........   PARAMETER

        CHARACTER*16, PARAMETER :: BLANK    = ' '
        CHARACTER*16, PARAMETER :: AIR_LAT  = 'AIR_LAT'
        CHARACTER*16, PARAMETER :: AIR_LON  = 'AIR_LON'
        CHARACTER*16, PARAMETER :: AIR_ELV  = 'AIR_ELV'
        CHARACTER*19, PARAMETER :: ENVCHK   = 'IOAPI_CHECK_HEADERS'

C...........   SAVED LOCAL VARIABLES and their descriptions:
C...........   NOTE:  the ANSI standard requires the use of SAVE statements
C...........   for variables which must retain their values from call to call.

        LOGICAL, SAVE :: CHKHDR
        LOGICAL, SAVE :: FIRSTIME =.TRUE.

C...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         ENVSTAT         !  return value for ENVYN()
        INTEGER         L, U, V         !  loop counters
        LOGICAL         INCREASING
        CHARACTER*160   MESG
        INTEGER         VGTYP, IERR
        REAL            VGLVS( MXLAYS3 + 1 )  !  vertical coord values.

C***********************************************************************
C   begin body of function  CKFILE3

        IF ( FIRSTIME ) THEN

            FIRSTIME = .FALSE.

            CHKHDR   = ENVYN( ENVCHK, 'Perform file-header checks?',
     &                       .FALSE., ENVSTAT )

            IF ( ENVSTAT .GT. 0 ) THEN
                MESG = 'Invalid value for environment vble "' //
     &                 ENVCHK // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
            END IF

        END IF          !  if firstime

C.......   If not chkhdr, just return TRUE:

        IF ( .NOT. CHKHDR ) THEN
            CKFLAG = .TRUE.
            RETURN
        END IF          !  if not chkhdr

C.......   Else perform checks:
C...........   First:  file type and type-specific dimension checks:

        IF ( FTYPE3( FID ) .EQ. DGRAPH3 ) THEN

            CKFLAG = .TRUE.
            RETURN

        ELSE IF ( FTYPE3( FID ) .EQ. DCTNRY3 ) THEN

            CKFLAG = .TRUE.
            RETURN

        ELSE IF ( FTYPE3( FID ) .EQ. CUSTOM3 ) THEN

            IF ( NCOLS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad blob-size NCOLS', NCOLS3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( FTYPE3( FID ) .EQ. GRDDED3  .OR.
     &            FTYPE3( FID ) .EQ. MPIGRD3  .OR.
     &            FTYPE3( FID ) .EQ. TSRIES3  .OR.              !  "exotic"
     &            FTYPE3( FID ) .EQ. PTRFLY3     ) THEN         !  grdded3's

            IF ( NCOLS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad NCOLS', NCOLS3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( NROWS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad NROWS', NROWS3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( FTYPE3( FID ) .EQ. PTRFLY3 ) THEN
                IF ( INDEX1( AIR_LAT, NVARS3( FID ),
     &                       VLIST3( 1,FID ) ) .LE. 0 ) THEN
                    MESG = 'Variable AIR_LAT not found in ' //
     &              'PTRFLY3-type file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                    CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                    CKFLAG = .FALSE.
                    RETURN
                END IF

                IF ( INDEX1( AIR_LON, NVARS3( FID ),
     &                       VLIST3( 1,FID ) ) .LE. 0 ) THEN
                    MESG = 'Variable AIR_LON not found in ' //
     &              'PTRFLY3-type file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                    CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                    CKFLAG = .FALSE.
                    RETURN
                END IF

                IF ( INDEX1( AIR_ELV, NVARS3( FID ),
     &                       VLIST3( 1,FID ) ) .LE. 0 ) THEN
                    MESG = 'Variable AIR_ELV not found in ' //
     &              'PTRFLY3-type file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                    CALL M3WARN( 'CKFILE', 0, 0, MESG )
                    CKFLAG = .FALSE.
                    RETURN
                END IF

            END IF              !  if ftype ptrfly3

        ELSE IF ( FTYPE3( FID ) .EQ. BNDARY3 ) THEN

            IF ( NCOLS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad NCOLS', NCOLS3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( NROWS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad NROWS', NROWS3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( ABS( NTHIK3( FID ) ) .GT. MIN( NCOLS3( FID ),
     &                                          NROWS3( FID ) )/2 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad boundary width NTHIK', NTHIK3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( FTYPE3( FID ) .EQ. IDDATA3 ) THEN

            IF ( NROWS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad max site count NROWS', NROWS3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( FTYPE3( FID ) .EQ. PROFIL3 ) THEN

            IF ( NROWS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad max site count NROWS', NROWS3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( NCOLS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad max level count NCOLS', NCOLS3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( FTYPE3( FID ) .EQ. GRNEST3 ) THEN

            IF ( NCOLS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad max cell-count NCOLS', NCOLS3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( NROWS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad max nest count NROWS', NROWS3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( FTYPE3( FID ) .EQ. SMATRX3 ) THEN

            IF ( NCOLS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad max matrix coeff-count NCOLS', NCOLS3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( NROWS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad matrix NROWS', NROWS3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( NTHIK3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad full-matrix col-count NTHIK', NTHIK3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( FTYPE3( FID ) .EQ. KFEVNT3 ) THEN

            IF ( NCOLS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad NCOLS', NCOLS3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( NROWS3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad NROWS', NROWS3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( NTHIK3( FID ) .LE. 0 ) THEN
                WRITE( MESG, 94010 )
     &          'Bad NTHIK', NTHIK3( FID ), 'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE

            WRITE( MESG, 94010 )
     &      'Illegal file type:', FTYPE3( FID ), 'for file "' //
     &      TRIM( FLIST3( FID ) ) // '"'
            CALL M3WARN( 'CKFILE3', 0, 0, MESG )
            CKFLAG = .FALSE.
            RETURN

        END IF

C...........   Next, checks on the variable-list

        IF ( NVARS3( FID ) .LT. 0 ) THEN

            WRITE( MESG, 94010 )
     &          'Illegal number of variables:', NVARS3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
            CALL M3WARN( 'CKFILE3', 0, 0, MESG )
            CKFLAG = .FALSE.
            RETURN

        ELSE IF ( NVARS3( FID ) .EQ. 0 ) THEN    !  _is_ legal, but unusual

            WRITE( MESG, 94010 )
     &          'WARNING:  number of variables:', NVARS3( FID ),
     &          'for file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
            CALL M3WARN( 'CKFILE3', 0, 0, MESG )

        END IF

        DO  22  U = 1, NVARS3( FID )

            IF ( .NOT. CKNAME( VLIST3( U,FID ) ) ) THEN
                WRITE( MESG,94000 )
     &              'Illegal variable name "' , VLIST3( U,FID ) ,
     &              '" in file ' , FLIST3( FID )
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            V = INDEXINT1( VTYPE3( U,FID ), NM3TYPES, M3TYPES )
            IF ( V .LE. 0 ) THEN

                WRITE( MESG, 94010 )
     &              'Illegal data type ', VTYPE3( U,FID ),
     &              'for variable "' //
     &              TRIM( VLIST3( U,FID ) ) //
     &              '" in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN

            END IF      !  end check on variable-type

            DO  11  V = 1, U-1          !  hunt for duplicate names

                IF( VLIST3( U,FID ) .EQ. VLIST3( V,FID ) ) THEN

                    WRITE( MESG, 94030 )
     &              'Variable name VLIST3D(', U, ') = "' //
     &              TRIM( VLIST3( U,FID ) ) //
     &              '" duplicates VLIST3D(', V, ') = "' //
     &              TRIM( VLIST3( V,FID ) ) //
     &              '" in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'

                    CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                    CKFLAG = .FALSE.
                    RETURN

                END IF

11          CONTINUE    !  end check for duplicates of this name

22      CONTINUE        !  end loop on variables U

C...........   Checks on the horizontal coordinate description:

        IF ( GDTYP3( FID ) .EQ. LATGRD3 ) THEN

            IF ( XORIG3( FID ) .LT. -180.0D0 .OR.
     &           XORIG3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad grid origin', XORIG3( FID ), 'in file "' //
     &               TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( YORIG3( FID ) .LT. -90.0D0 .OR.
     &           YORIG3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad grid origin', YORIG3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. LAMGRD3 ) THEN

            IF ( XCENT3( FID ) .LT. -180.0D0 .OR.
     &           XCENT3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', XCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( YCENT3( FID ) .LT. -90.0D0 .OR.
     &           YCENT3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', YCENT3( FID ),
     &              'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_ALP3( FID ) .LT. -90.0D0 .OR.
     &           P_ALP3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_BET3( FID ) .LT. P_ALP3( FID ) .OR.
     &           P_BET3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-BETA', P_BET3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID ) .LT. -180.0D0 .OR.
     &           P_GAM3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. MERGRD3 ) THEN

            IF ( XCENT3( FID ) .LT. -180.0D0 .OR.
     &           XCENT3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', XCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
            END IF

            IF ( YCENT3( FID ) .LT. -90.0D0 .OR.
     &           YCENT3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', YCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
            END IF

            IF ( P_ALP3( FID ) .LT. -90.0D0 .OR.
     &           P_ALP3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_BET3( FID ) .LT. -180.0D0 .OR.
     &           P_BET3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-BETA', P_BET3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID ) .LT. -180.0D0 .OR.
     &           P_GAM3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID) .EQ. POLGRD3 ) THEN

            IF ( XCENT3( FID) .LT. -180.0D0 .OR.
     &           XCENT3( FID) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', XCENT3( FID), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( YCENT3( FID) .LT. -90.0D0 .OR.
     &           YCENT3( FID) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', YCENT3( FID), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_ALP3( FID) .NE. -1.0D0 .AND.
     &           P_ALP3( FID) .NE.  1.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_BET3( FID) .LT. -90.0D0 .OR.
     &           P_BET3( FID) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-BETA', P_BET3( FID), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID) .LT. -180.0D0 .OR.
     &           P_GAM3( FID) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. STEGRD3 ) THEN

            IF ( XCENT3( FID ) .LT. -180.0D0 .OR.
     &           XCENT3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', XCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( YCENT3( FID ) .LT. -90.0D0 .OR.
     &           YCENT3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', YCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_ALP3( FID ) .LT. -90.0D0 .OR.
     &           P_ALP3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_BET3( FID ) .LT. -180.0D0 .OR.
     &           P_BET3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-BETA', P_BET3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID ) .LT. -180.0D0 .OR.
     &           P_GAM3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. UTMGRD3 ) THEN

            IF ( P_ALP3( FID ) .LT.  0.9D0 .OR.
     &           P_ALP3( FID ) .GT. 36.1D0 .OR.
     &           ABS( P_ALP3( FID ) -
     &                DBLE( NINT( P_ALP3( FID ) ) ) ) .GT. 0.01 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. EQMGRD3 ) THEN

            IF ( XCENT3( FID ) .LT. -180.0D0 .OR.
     &           XCENT3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', XCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( YCENT3( FID ) .LT. -90.0D0 .OR.
     &           YCENT3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', YCENT3( FID ),
     &              'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_ALP3( FID ) .LT. -90.0D0 .OR.
     &           P_ALP3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID ) .LT. -180.0D0 .OR.
     &           P_GAM3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. TRMGRD3 ) THEN

            IF ( XCENT3( FID ) .LT. -180.0D0 .OR.
     &           XCENT3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', XCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( YCENT3( FID ) .LT. -90.0D0 .OR.
     &           YCENT3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', YCENT3( FID ),
     &              'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_ALP3( FID ) .LT. -90.0D0 .OR.
     &           P_ALP3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID ) .LT. -180.0D0 .OR.
     &           P_GAM3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. ALBGRD3 ) THEN

            IF ( XCENT3( FID ) .LT. -180.0D0 .OR.
     &           XCENT3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', XCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( YCENT3( FID ) .LT. -90.0D0 .OR.
     &           YCENT3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', YCENT3( FID ),
     &              'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_ALP3( FID ) .LT. -90.0D0 .OR.
     &           P_ALP3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_BET3( FID ) .LT. P_ALP3( FID ) .OR.
     &           P_BET3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-BETA', P_BET3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID ) .LT. -180.0D0 .OR.
     &           P_GAM3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. LEQGRD3 ) THEN

            IF ( P_ALP3( FID ) .LT. -90.0D0 .OR.
     &           P_ALP3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-ALPHA', P_ALP3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID ) .LT. -180.0D0 .OR.
     &           P_GAM3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. SINUGRD3 ) THEN

            IF ( XCENT3( FID ) .LT. -180.0D0 .OR.
     &           XCENT3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', XCENT3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( YCENT3( FID ) .LT. -90.0D0 .OR.
     &           YCENT3( FID ) .GT.  90.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad X-Y origin', YCENT3( FID ),
     &              'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

            IF ( P_GAM3( FID ) .LT. -180.0D0 .OR.
     &           P_GAM3( FID ) .GT.  180.0D0 ) THEN
                WRITE( MESG, 94020 )
     &              'Bad PROJ-GAMMA', P_GAM3( FID ), 'in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN
            END IF

        ELSE IF ( GDTYP3( FID ) .EQ. IMISS3  ) THEN   !  "other" -- legal but unusual

            WRITE( MESG, 94010 )
     &          'WARNING:  Horizontal grid/coordinate type:',
     &          GDTYP3( FID ),
     &          '"MISSING"  in file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
            CALL M3WARN( 'CKFILE3', 0, 0, MESG )

        ELSE    !  illegal grid type

            WRITE( MESG, 94010 )
     &         'Illegal horizontal grid/coordinate type:',
     &          GDTYP3( FID ), 'in file "' //
     &          TRIM( FLIST3( FID ) ) // '"'
            CALL M3WARN( 'CKFILE3', 0, 0, MESG )
            CKFLAG = .FALSE.
            RETURN

        END IF  !  if  gdtyp3d = lamgrd3, etc.

C...........   Checks on the vertical coordinate description:

        IF ( NLAYS3( FID ) .LT. 1 .AND.
     &       FTYPE3( FID ) .GE. CUSTOM3 ) THEN

            WRITE( MESG, 94010 )
     &         'Illegal vertical layer dimension:', NLAYS3( FID ),
     &         'in file "' //
     &         TRIM( FLIST3( FID ) ) // '"'
            CALL M3WARN( 'CKFILE3', 0, 0, MESG )
            CKFLAG = .FALSE.
            RETURN

        ELSE IF ( NLAYS3( FID ) .GT. 1 ) THEN

            INCREASING = ( VGLVS3( 2,FID ) .GT. VGLVS3( 1,FID ) )

            DO  L = 2, MIN( NLAYS3( FID ), MXLAYS3 )

                IF ( INCREASING .NEQV.
     &               ( VGLVS3( L+1,FID ) .GT. VGLVS3( L,FID ) ) ) THEN

                    WRITE( MESG, 94010 )
     &              'Bad layer monotonicity at layer', L, 'in file "'//
     &              TRIM( FLIST3( FID ) ) // '"'

                    CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                    CKFLAG = .FALSE.
                    RETURN

                END IF

            END DO

            IF ( VGTYP3(FID) .EQ. IMISS3  ) THEN   !  "other" -- legal but unusual

                WRITE( MESG, 94010 )
     &              'WARNING:  Vertical grid/coordinate type:',
     &              VGTYP3(FID),
     &              '"MISSING" in file "' //
     &              TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )

            ELSE IF ( ( VGTYP3(FID) .NE. VGSGPN3 ) .AND.
     &                ( VGTYP3(FID) .NE. VGSGPH3 ) .AND.
     &                ( VGTYP3(FID) .NE. VGSIGZ3 ) .AND.
     &                ( VGTYP3(FID) .NE. VGPRES3 ) .AND.
     &                ( VGTYP3(FID) .NE. VGZVAL3 ) .AND.
     &                ( VGTYP3(FID) .NE. VGHVAL3 ) .AND.
     &                ( VGTYP3(FID) .NE. VGWRFEM ) .AND.
     &                ( VGTYP3(FID) .NE. VGWRFNM ) ) THEN

                WRITE( MESG, 94010 )
     &           'Unknown vertical grid/coordinate type:', VGTYP3(FID),
     &            'in file "' // TRIM( FLIST3( FID ) ) // '"'
                CALL M3WARN( 'CKFILE3', 0, 0, MESG )
                CKFLAG = .FALSE.
                RETURN

            END IF  !  if  vgtyp3d = vgsgph3, etc.

        END IF          !  if nlays < 1, etc.

C...........   If you get to here:  all checks passed:

        CKFLAG = .TRUE.
        RETURN

C******************  FORMAT  STATEMENTS   ******************************

C...........   Internal buffering formats............ 94xxx

94000   FORMAT( 99( A, : ) )

94010   FORMAT( A, I10, :, 2X, A )

94020   FORMAT( A, 1PG14.7, :, 2X, A )

94030   FORMAT( 4 ( A, I5, :, 2X ) )

        END FUNCTION CKFILE3

max_stars_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork

max_issues_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork

max_forks_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork


text:
      subroutine adaptwt1(nfft,ne,kspec,dvar,evalu1,mxfreq,yk,
     $                    evalu,sqev,bk,sk,eigsp,delsp,mxwt,spec,
     $                    se,wt,err,jack)
c
c  calls r1mach,fzero
c
      double precision evalu,sqev,evalu1,sie,sumwt,eigsum,sumdel,var
      logical jack
      complex yk
      dimension evalu(kspec),sqev(kspec),evalu1(kspec),
     $          yk(mxfreq,kspec),se(ne),spec(ne),wt(mxwt,kspec),
     $          err(ne),eigsp(kspec),delsp(kspec),
     $          bk(kspec),sk(kspec)
      external fspec
c
      nfft2=nfft/2
      xnfft=nfft
      xkspec=kspec
      sie=0.
      do 10 j=1,kspec
        bk(j)=dvar*evalu1(j)
        evalu(j)=1.-evalu1(j)
        sqev(j)=sqrt(evalu(j))
   10   sie=sie+1./evalu(j)
      siek=sie/xkspec
c
c  step through frequencies and find weighted spectrum iteratively
c  for each
      small=r1mach(1)
      big=r1mach(2)
      rerr=4.*r1mach(4)
      aerr=1.e6*small
      do 40 i=1,ne
        b=big
        c=small
        do 30 j=1,kspec
          sk(j)=siek*evalu(j)*abs(yk(i,j))**2
          b=min(b,sk(j))
          c=max(c,sk(j))
30	  continue
        r=0.5*(sk(1)+sk(2))
        call fzero(fspec,b,c,r,rerr,aerr,iflag,evalu,bk,kspec)
        if(iflag.ne.1)then
          write(6,*)' spectrum recursion did not converge'
          write(6,*)' frequency=',float(i-1)/xnfft,' iflag=',iflag
        endif
   40   spec(i)=b
c  compute weights
      do 50 i=1,ne
        se(i)=0.
        sumwt=0.
        do 45 j=1,kspec
          wt(i,j)=sqev(j)*spec(i)/(evalu(j)*spec(i)+bk(j))
          sumwt=sumwt+wt(i,j)**2
          if((i.eq.1).or.(i.eq.nfft2+1))then
            se(i)=se(i)+evalu(j)*wt(i,j)**2
          else
            se(i)=se(i)+2.*evalu(j)*wt(i,j)**2
          endif
   45     continue
        sumwt=sqrt(sumwt)
        do 50 j=1,kspec
   50     wt(i,j)=wt(i,j)/sumwt
      if (.not.jack) return
c
c  calculate jackknife estimate of 95% confidence limits
c
      do 110 i=1,ne
        eigsum=0.
        do 70 j=1,kspec
          eigsp(j)=siek*evalu(j)*(wt(i,j)*abs(yk(i,j)))**2
   70     eigsum=eigsum+eigsp(j)
        sumdel=0.
        do 90 j=1,kspec
          delsp(j)=log(eigsum-eigsp(j))
   90     sumdel=sumdel+delsp(j)
        sumdel=sumdel/xkspec
        var=0.
        do 100 j=1,kspec
  100     var=var+(sumdel-delsp(j))**2
        var=(xkspec-1.)*var/xkspec
  110   err(i)=exp(1.96*sqrt(var))
      return
      end

c $Id$


text:
!==============================================================================!
  subroutine Info_Mod_Iter_Start()
!------------------------------------------------------------------------------!
!   Essentially creates a box in which iteration residuls will be written.     !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Comm_Mod, only: this_proc
!------------------------------------------------------------------------------!
  implicit none
!-----------------------------------[Locals]-----------------------------------!
  integer :: i, l
!==============================================================================!

  if (this_proc < 2) then

    ! Create frame
    do i = 1, L_LINE, L_LINE-1
      iter_info % line_lead      (i:i) = '#'

      ! For normal lines
      do l = 1, 4
        iter_info % lines(l)     (i:i) = '#'
      end do

      ! For user lines
      do l = 1, MAX_USER_LINES
        iter_info % lines_user(l)(i:i) = '#'
      end do
      iter_info % line_trail     (i:i) = '#'
    end do

    do i = 2, L_LINE-1
      iter_info % line_lead (i:i) = '='
      iter_info % line_trail(i:i) = '-'
    end do

    ! Create separators (character must be length of L_BOX)
    do i = 2, L_LINE-L_BOX, L_BOX

      ! For normal lines
      do l = 1, 4
        write(iter_info % lines(l)      (i:i+L_BOX-1), '(a21)') '|'
      end do

      ! For user lines
      do l = 1, MAX_USER_LINES
        write(iter_info % lines_user(l) (i:i+L_BOX-1), '(a21)') '|'
      end do
      write(iter_info % line_lead (i+L_BOX-1 :  &
                                   i+L_BOX-1),   '(a1)') '+'
      write(iter_info % line_trail(i+L_BOX-1 :  &
                                   i+L_BOX-1),   '(a1)') '+'
    end do

  end if

  end subroutine

max_stars_repo_name: MassimoBorrelliPhysicist/T-Flows

max_issues_repo_name: MassimoBorrelliPhysicist/T-Flows

max_forks_repo_name: MassimoBorrelliPhysicist/T-Flows