controlVector_mod sourceΒΆ

  1module controlVector_mod
  2  ! MODULE controlVector_mod (prefix='cvm' category='6. High-level data objects')
  3  !
  4  !:Purpose: The control vector and related information.  
  5  !
  6  use utilities_mod
  7  implicit none
  8  save
  9  private
 10
 11  ! public variables
 12  public              :: cvm_nvadim, cvm_nvadim_mpiglobal
 13  ! public procedures
 14  public              :: cvm_setupSubVector, cvm_getSubVector, cvm_getSubVector_mpiglobal
 15  public              :: cvm_getSubVector_r4, cvm_getSubVector_mpiglobal_r4
 16  public              :: cvm_subVectorExists
 17
 18  type struct_cvm
 19    private
 20    character(len=9) :: label                  = 'XXXXXXXXX'
 21    character(len=4) :: BmatrixType            = 'XXXX'
 22    integer          :: dimVector              = 0
 23    integer          :: subVectorBeg           = 1
 24    integer          :: subVectorEnd           = 0
 25    integer          :: dimVector_mpiglobal    = 0
 26    integer          :: subVectorBeg_mpiglobal = 1
 27    integer          :: subVectorEnd_mpiglobal = 0
 28  end type struct_cvm
 29
 30  integer, parameter :: maxNumVectors = 50
 31  integer            :: numVectors = 0
 32  type(struct_cvm)   :: cvm_vector(maxNumVectors)
 33
 34  integer             :: cvm_nvadim
 35  integer             :: cvm_nvadim_mpiglobal
 36
 37contains
 38
 39  subroutine cvm_setupSubVector(label, BmatrixType, dimVector)
 40    implicit none
 41
 42    ! Arguments:
 43    character(len=*), intent(in) :: label
 44    character(len=*), intent(in) :: BmatrixType
 45    integer,          intent(in) :: dimVector
 46
 47    ! Locals:
 48    integer :: ierr, dimVector_mpiglobal
 49
 50    if ( numVectors == maxNumVectors ) then
 51      call utl_abort('cvm_setupSubVector: number of allocated subvectors already at maximum allowed')
 52    end if
 53
 54    call rpn_comm_allreduce(dimVector, dimVector_mpiglobal,  &
 55                            1, 'MPI_INTEGER', 'MPI_SUM', 'GRID', ierr)
 56
 57    ! just return if subVector dimension is zero on all MPI tasks
 58    if ( dimVector_mpiglobal == 0 ) return
 59
 60    numVectors = numVectors + 1
 61
 62    if ( any(cvm_vector(:)%label == label) ) then
 63      write(*,*) 'cvm_setupSubVector: label = ', trim(label)
 64      call utl_abort('cvm_setupSubVector: this label is already present')
 65    end if
 66
 67    cvm_vector(numVectors)%label = label
 68    cvm_vector(numVectors)%BmatrixType = BmatrixType
 69    cvm_vector(numVectors)%dimVector = dimVector
 70    cvm_vector(numVectors)%dimVector_mpiglobal = dimVector_mpiglobal
 71
 72    if ( numVectors == 1 ) then
 73      cvm_vector(numVectors)%subVectorBeg = 1
 74      cvm_vector(numVectors)%subVectorEnd = cvm_vector(numVectors)%dimVector
 75
 76      cvm_vector(numVectors)%subVectorBeg_mpiglobal = 1
 77      cvm_vector(numVectors)%subVectorEnd_mpiglobal = cvm_vector(numVectors)%dimVector_mpiglobal
 78    else
 79      cvm_vector(numVectors)%subVectorBeg = 1 + cvm_vector(numVectors-1)%subVectorEnd
 80      cvm_vector(numVectors)%subVectorEnd = cvm_vector(numVectors)%dimVector +   &
 81                                            cvm_vector(numVectors-1)%subVectorEnd
 82
 83      cvm_vector(numVectors)%subVectorBeg_mpiglobal = 1 + cvm_vector(numVectors-1)%subVectorEnd_mpiglobal
 84      cvm_vector(numVectors)%subVectorEnd_mpiglobal = cvm_vector(numVectors)%dimVector_mpiglobal +  &
 85                                                      cvm_vector(numVectors-1)%subVectorEnd_mpiglobal
 86    end if
 87
 88    cvm_nvadim = sum(cvm_vector(1:numVectors)%dimVector)
 89    cvm_nvadim_mpiglobal = sum(cvm_vector(1:numVectors)%dimVector_mpiglobal)
 90
 91    write(*,*) 'cvm_setupSubVector: '
 92    write(*,*) '   added subVector with label                 = ', cvm_vector(numVectors)%label
 93    write(*,*) '   added subVector of type                    = ', cvm_vector(numVectors)%Bmatrixtype
 94    write(*,*) '   added subVector with dimension             = ', cvm_vector(numVectors)%dimVector
 95    write(*,*) '   added subVector with dimension (mpiglobal) = ', cvm_vector(numVectors)%dimVector_mpiglobal
 96    write(*,*) '   current total dimension             = ', cvm_nvadim
 97    write(*,*) '   current total dimension (mpiglobal) = ', cvm_nvadim_mpiglobal
 98
 99  end subroutine cvm_setupSubVector
100
101
102  function cvm_indexFromLabel(subVectorLabel) result(subVectorIndex)
103    implicit none
104
105    ! Arguments:
106    character(len=*), intent(in) :: subVectorLabel
107    ! Result:
108    integer :: subVectorIndex
109
110    ! Locals:
111    logical :: found
112
113    found = .false.
114    index_loop: do subVectorIndex = 1, numVectors
115      if ( trim(cvm_vector(subVectorIndex)%label) == trim(subVectorLabel) ) then
116        found = .true.
117        exit index_loop
118      end if
119    end do index_loop
120
121    if ( .not.found ) then
122      subVectorIndex = -1
123    end if
124
125  end function cvm_indexFromLabel
126
127
128  function cvm_subVectorExists(subVectorLabel) result(exists)
129    implicit none
130
131    ! Arguments:
132    character(len=*), intent(in) :: subVectorLabel
133    ! Result:
134    logical :: exists
135
136    ! Locals:
137    integer :: subVectorIndex
138
139    subVectorIndex = cvm_indexFromLabel(subVectorLabel)
140
141    if ( subVectorIndex < 0 ) then
142      exists = .false.
143      return
144    end if
145
146    if ( cvm_vector(subVectorIndex)%dimVector_mpiglobal > 0 ) then
147      exists = .true.
148    else
149      exists = .false.
150    end if
151
152  end function cvm_subVectorExists
153
154
155  function cvm_getSubVector(controlVector,subVectorLabel) result(subVector)
156    implicit none
157
158    ! Arguments:
159    character(len=*), intent(in) :: subVectorLabel
160    real*8, target,   intent(in) :: controlVector(:)
161    ! Result:
162    real*8, pointer :: subVector(:)
163
164    ! Locals:
165    integer         :: subVectorIndex, indexBeg, indexEnd
166
167    subVectorIndex = cvm_indexFromLabel(subVectorLabel)
168
169    if( subVectorIndex < 0 ) then
170      call utl_abort('cvm_getSubVector: invalid subVector label')
171    end if
172
173    indexBeg = cvm_vector(subVectorIndex)%subVectorBeg
174    indexEnd = cvm_vector(subVectorIndex)%subVectorEnd
175    subVector => controlVector(indexBeg:indexEnd)
176
177  end function cvm_getSubVector
178
179
180  function cvm_getSubVector_r4(controlVector,subVectorLabel) result(subVector)
181    implicit none
182
183    ! Arguments:
184    character(len=*), intent(in) :: subVectorLabel
185    real*4, target,   intent(in) :: controlVector(:)
186    ! Result:
187    real*4, pointer :: subVector(:)
188
189    ! Locals:
190    integer         :: subVectorIndex, indexBeg, indexEnd
191
192    subVectorIndex = cvm_indexFromLabel(subVectorLabel)
193
194    if( subVectorIndex < 0 ) then
195      call utl_abort('cvm_getSubVector_r4: invalid subVector label')
196    end if
197
198    indexBeg = cvm_vector(subVectorIndex)%subVectorBeg
199    indexEnd = cvm_vector(subVectorIndex)%subVectorEnd
200    subVector => controlVector(indexBeg:indexEnd)
201
202  end function cvm_getSubVector_r4
203
204
205  function cvm_getSubVector_mpiglobal(controlVector,subVectorLabel) result(subVector)
206    implicit none
207
208    ! Arguments:
209    character(len=*), intent(in) :: subVectorLabel
210    real*8, target,   intent(in) :: controlVector(:)
211    ! Result:
212    real*8, pointer :: subVector(:)
213
214    ! Locals:
215    integer         :: subVectorIndex, indexBeg, indexEnd
216
217    subVectorIndex = cvm_indexFromLabel(subVectorLabel)
218
219    if( subVectorIndex < 0 ) then
220      call utl_abort('cvm_getSubVector_mpiglobal: invalid subVector label')
221    end if
222
223    indexBeg = cvm_vector(subVectorIndex)%subVectorBeg_mpiglobal
224    indexEnd = cvm_vector(subVectorIndex)%subVectorEnd_mpiglobal
225    subVector => controlVector(indexBeg:indexEnd)
226
227  end function cvm_getSubVector_mpiglobal
228
229
230  function cvm_getSubVector_mpiglobal_r4(controlVector,subVectorLabel) result(subVector)
231    implicit none
232
233    ! Arguments:
234    character(len=*), intent(in) :: subVectorLabel
235    real*4, target,   intent(in) :: controlVector(:)
236    ! Result:
237    real*4, pointer :: subVector(:)
238
239    ! Locals:
240    integer         :: subVectorIndex, indexBeg, indexEnd
241
242    subVectorIndex = cvm_indexFromLabel(subVectorLabel)
243
244    if( subVectorIndex < 0 ) then
245      call utl_abort('cvm_getSubVector_mpiglobal_r4: invalid subVector label')
246    end if
247
248    indexBeg = cvm_vector(subVectorIndex)%subVectorBeg_mpiglobal
249    indexEnd = cvm_vector(subVectorIndex)%subVectorEnd_mpiglobal
250    subVector => controlVector(indexBeg:indexEnd)
251
252  end function cvm_getSubVector_mpiglobal_r4
253
254end module controlVector_mod