Rocstar  1.0
Rocstar multiphysics simulation application
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
RFLU_PickSpecialCells.F90
Go to the documentation of this file.
1 ! *********************************************************************
2 ! * Rocstar Simulation Suite *
3 ! * Copyright@2015, Illinois Rocstar LLC. All rights reserved. *
4 ! * *
5 ! * Illinois Rocstar LLC *
6 ! * Champaign, IL *
7 ! * www.illinoisrocstar.com *
8 ! * sales@illinoisrocstar.com *
9 ! * *
10 ! * License: See LICENSE file in top level of distribution package or *
11 ! * http://opensource.org/licenses/NCSA *
12 ! *********************************************************************
13 ! *********************************************************************
14 ! * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, *
15 ! * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES *
16 ! * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND *
17 ! * NONINFRINGEMENT. IN NO EVENT SHALL THE CONTRIBUTORS OR *
18 ! * COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *
19 ! * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, *
20 ! * Arising FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE *
21 ! * USE OR OTHER DEALINGS WITH THE SOFTWARE. *
22 ! *********************************************************************
23 ! ******************************************************************************
24 !
25 ! Purpose: Pick special cells.
26 !
27 ! Description: None.
28 !
29 ! Input:
30 ! pRegion Pointer to region data
31 !
32 ! Output: None.
33 !
34 ! Notes: None.
35 !
36 ! ******************************************************************************
37 !
38 ! $Id: RFLU_PickSpecialCells.F90,v 1.11 2008/12/06 08:45:04 mtcampbe Exp $
39 !
40 ! Copyright: (c) 2003-2005 by the University of Illinois
41 !
42 ! ******************************************************************************
43 
44 SUBROUTINE rflu_pickspecialcells(pRegion)
45 
46  USE modglobal, ONLY: t_global
47  USE moddatatypes
48  USE modparameters
49  USE moderror
50  USE modbndpatch, ONLY: t_patch
51  USE modgrid, ONLY: t_grid
52  USE moddatastruct, ONLY: t_region
53  USE modsortsearch
54 
55  USE rflu_modgrid
56 
57  IMPLICIT NONE
58 
59 ! ******************************************************************************
60 ! Declarations and definitions
61 ! ******************************************************************************
62 
63 ! ==============================================================================
64 ! Arguments
65 ! ==============================================================================
66 
67  TYPE(t_region), POINTER :: pregion
68 
69 ! ==============================================================================
70 ! Locals
71 ! ==============================================================================
72 
73  CHARACTER :: infotype,stenciltype
74  CHARACTER(CHRLEN) :: rcsidentstring
75  INTEGER :: cellindx,errorflag,faceindx,fndir,fndirend,icellsspecial,icl, &
76  iloc,ipatch,nvertpercell,patchindx,vertindx
77  INTEGER :: v(8)
78  TYPE(t_global), POINTER :: global
79  TYPE(t_grid), POINTER :: pgrid
80  TYPE(t_patch), POINTER :: ppatch
81 
82 ! ******************************************************************************
83 ! Start
84 ! ******************************************************************************
85 
86  rcsidentstring = '$RCSfile: RFLU_PickSpecialCells.F90,v $ $Revision: 1.11 $'
87 
88  global => pregion%global
89 
90  CALL registerfunction(global,'RFLU_PickSpecialCells', &
91  'RFLU_PickSpecialCells.F90')
92 
93  IF ( global%verbLevel > verbose_none ) THEN
94  WRITE(stdout,'(A,1X,A)') solver_name,'Picking special cells...'
95  WRITE(stdout,'(A,3X,A,1X,I5.5)') solver_name,'Global region:', &
96  pregion%iRegionGlobal
97  END IF ! global%verbLevel
98 
99 ! ******************************************************************************
100 ! Set pointers and initialize
101 ! ******************************************************************************
102 
103  pgrid => pregion%grid
104 
105  icellsspecial = 0
106  pgrid%cellsSpecial(1:ncells_special_max) = 0
107 
108 ! ******************************************************************************
109 ! Get information from user
110 ! ******************************************************************************
111 
112  WRITE(stdout,'(A,5X,A)') solver_name,'Enter information on special cells:'
113  WRITE(stdout,'(A,7X,A)') solver_name,'b - cell adjacent to boundary face'
114  WRITE(stdout,'(A,7X,A)') solver_name,'c - single cell'
115  WRITE(stdout,'(A,7X,A)') solver_name,'f - cells adjacent to interior face'
116  WRITE(stdout,'(A,7X,A)') solver_name,'s - stencil members'
117  WRITE(stdout,'(A,7X,A)') solver_name,'v - cells meeting at vertex'
118  WRITE(stdout,'(A,7X,A)') solver_name,'q - quit'
119 
120 ! ******************************************************************************
121 ! Set up infinite loop
122 ! ******************************************************************************
123 
124  DO
125 
126 ! ==============================================================================
127 ! Enter information type
128 ! ==============================================================================
129 
130  WRITE(stdout,'(A,3X,A)') solver_name,'Enter information type:'
131  READ(stdin,'(A)') infotype
132 
133  SELECT CASE ( infotype )
134 
135 ! ------------------------------------------------------------------------------
136 ! Cell adjacent to boundary face
137 ! ------------------------------------------------------------------------------
138 
139  CASE ( 'b' )
140  WRITE(stdout,'(A,5X,A)') solver_name,'Enter patch index:'
141  READ(stdin,*,iostat=errorflag) patchindx
142 
143  IF ( errorflag /= err_none ) THEN
144  global%warnCounter = global%warnCounter + 1
145 
146  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
147  cycle
148  END IF ! errorFlag
149 
150  IF ( patchindx > 0 .AND. patchindx <= pgrid%nPatches ) THEN
151  ppatch => pregion%patches(patchindx)
152 
153  WRITE(stdout,'(A,5X,A)') solver_name,'Enter face index:'
154  READ(stdin,*,iostat=errorflag) faceindx
155 
156  IF ( errorflag /= err_none ) THEN
157  global%warnCounter = global%warnCounter + 1
158 
159  WRITE(stdout,'(A,5X,A)') solver_name, &
160  '*** WARNING *** Invalid input.'
161  cycle
162  END IF ! errorFlag
163 
164  IF ( faceindx > 0 .AND. faceindx <= ppatch%nBFacesTot ) THEN
165  IF ( icellsspecial == ncells_special_max ) THEN
166  CALL errorstop(global,err_ncells_special_max,__line__)
167  END IF ! iCellsSpecial
168 
169  icellsspecial = icellsspecial + 1
170  pgrid%cellsSpecial(icellsspecial) = ppatch%bf2c(faceindx)
171 
172  WRITE(stdout,'(A,5X,A,1X,I8)') solver_name,'Added cell:', &
173  ppatch%bf2c(faceindx)
174  ELSE
175  global%warnCounter = global%warnCounter + 1
176 
177  WRITE(stdout,'(A,5X,A)') solver_name, &
178  '*** WARNING *** Invalid input.'
179  cycle
180  END IF ! faceIndx
181  ELSE
182  global%warnCounter = global%warnCounter + 1
183 
184  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
185  cycle
186  END IF ! patchIndx
187 
188 ! ------------------------------------------------------------------------------
189 ! Single cell
190 ! ------------------------------------------------------------------------------
191 
192  CASE ( 'c' )
193  WRITE(stdout,'(A,5X,A)') solver_name,'Enter cell index:'
194  READ(stdin,*,iostat=errorflag) cellindx
195 
196  IF ( errorflag /= err_none ) THEN
197  global%warnCounter = global%warnCounter + 1
198 
199  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
200  cycle
201  END IF ! errorFlag
202 
203  IF ( cellindx > 0 .AND. cellindx <= pgrid%nCellsTot ) THEN
204  IF ( icellsspecial == ncells_special_max ) THEN
205  CALL errorstop(global,err_ncells_special_max,__line__)
206  END IF ! iCellsSpecial
207 
208  icellsspecial = icellsspecial + 1
209  pgrid%cellsSpecial(icellsspecial) = cellindx
210  ELSE
211  global%warnCounter = global%warnCounter + 1
212 
213  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
214  cycle
215  END IF ! cellIndx
216 
217 ! ------------------------------------------------------------------------------
218 ! Cells adjacent to interior face
219 ! ------------------------------------------------------------------------------
220 
221  CASE ( 'f' )
222  WRITE(stdout,'(A,5X,A)') solver_name,'Enter interior face index:'
223  READ(stdin,*,iostat=errorflag) faceindx
224 
225  IF ( errorflag /= err_none ) THEN
226  global%warnCounter = global%warnCounter + 1
227 
228  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
229  cycle
230  END IF ! errorFlag
231 
232  IF ( faceindx > 0 .AND. faceindx <= pgrid%nFacesTot ) THEN
233  IF ( icellsspecial == ncells_special_max-1 ) THEN ! NOTE '-1'
234  CALL errorstop(global,err_ncells_special_max,__line__)
235  END IF ! iCellsSpecial
236 
237  icellsspecial = icellsspecial + 1
238  pgrid%cellsSpecial(icellsspecial) = pgrid%f2c(1,faceindx)
239 
240  icellsspecial = icellsspecial + 1
241  pgrid%cellsSpecial(icellsspecial) = pgrid%f2c(2,faceindx)
242 
243  WRITE(stdout,'(A,5X,A,1X,I8,1X,A,1X,I8)') solver_name, &
244  'Added cells:',pgrid%f2c(1,faceindx),'and', &
245  pgrid%f2c(2,faceindx)
246  ELSE
247  global%warnCounter = global%warnCounter + 1
248 
249  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
250  cycle
251  END IF ! faceIndx
252 
253 ! ------------------------------------------------------------------------------
254 ! Stencil members
255 ! ------------------------------------------------------------------------------
256 
257  CASE ( 's' )
258  WRITE(stdout,'(A,7X,A)') solver_name,'Enter type of stencil:'
259  WRITE(stdout,'(A,9X,A)') solver_name,'b - boundary-face stencil'
260  WRITE(stdout,'(A,9X,A)') solver_name,'c - cell stencil'
261  WRITE(stdout,'(A,9X,A)') solver_name,'f - face stencil'
262  WRITE(stdout,'(A,9X,A)') solver_name,'v - vertex stencil'
263  READ(stdin,'(A)') stenciltype
264 
265  SELECT CASE ( stenciltype )
266 
267 ! ------- Boundary-face stencil ------------------------------------------------
268 
269  CASE ( 'b' )
270  WRITE(stdout,'(A,7X,A)') solver_name,'Enter patch index:'
271  READ(stdin,*,iostat=errorflag) ipatch
272 
273  IF ( ipatch < 1 .OR. ipatch > pgrid%nPatches ) THEN
274  global%warnCounter = global%warnCounter + 1
275 
276  WRITE(stdout,'(A,5X,A)') solver_name, &
277  '*** WARNING *** Invalid input.'
278  cycle
279  END IF ! iPatch
280 
281  ppatch => pregion%patches(ipatch)
282 
283  WRITE(stdout,'(A,7X,A)') solver_name,'Enter face index:'
284  READ(stdin,*,iostat=errorflag) faceindx
285 
286  IF ( faceindx > 0 .AND. faceindx <= ppatch%nBFaces ) THEN
287  WRITE(stdout,'(A,9X,A,1X,I3)') solver_name, &
288  'Number of stencil members:',ppatch%bf2cs(faceindx)%nCellMembs
289 
290  DO icl = 1,ppatch%bf2cs(faceindx)%nCellMembs
291  icellsspecial = icellsspecial + 1
292 
293  IF ( icellsspecial == ncells_special_max ) THEN
294  CALL errorstop(global,err_ncells_special_max,__line__)
295  END IF ! iCellsSpecial
296 
297  pgrid%cellsSpecial(icellsspecial) = &
298  ppatch%bf2cs(faceindx)%cellMembs(icl)
299  END DO ! icl
300  ELSE
301  global%warnCounter = global%warnCounter + 1
302 
303  WRITE(stdout,'(A,5X,A)') solver_name, &
304  '*** WARNING *** Invalid input.'
305  cycle
306  END IF ! cellIndx
307 
308 ! ------- Cell stencil ---------------------------------------------------------
309 
310  CASE ( 'c' )
311  SELECT CASE ( pregion%mixtInput%stencilDimensCells )
312  CASE ( 1 )
313  IF ( ASSOCIATED(pgrid%c2cs1D) .EQV. .false. ) THEN
314  global%warnCounter = global%warnCounter + 1
315 
316  WRITE(stdout,'(A,7X,A)') solver_name, &
317  '*** WARNING *** Stencil not built.'
318  cycle
319  END IF ! ASSOCIATED
320 
321  SELECT CASE ( pregion%mixtInput%dimens )
322  CASE ( 1 )
323  fndirend = 1
324  CASE ( 2 )
325  fndirend = 2
326  CASE ( 3 )
327  fndirend = 3
328  CASE default ! Defensive coding
329  CALL errorstop(global,err_reached_default,__line__)
330  END SELECT ! pRegion%mixtInput%dimensCells
331 
332  WRITE(stdout,'(A,7X,A)') solver_name,'Enter cell index:'
333  READ(stdin,*,iostat=errorflag) cellindx
334 
335  WRITE(stdout,'(A,7X,A)') solver_name,'Enter direction:'
336  READ(stdin,*,iostat=errorflag) fndir
337 
338  IF ( fndir < 1 .OR. fndir > fndirend ) THEN
339  global%warnCounter = global%warnCounter + 1
340 
341  WRITE(stdout,'(A,5X,A)') solver_name, &
342  '*** WARNING *** Invalid input.'
343  cycle
344  END IF ! fnDir
345 
346  IF ( cellindx > 0 .AND. cellindx <= pgrid%nCellsTot ) THEN
347  IF ( icellsspecial == ncells_special_max ) THEN
348  CALL errorstop(global,err_ncells_special_max,__line__)
349  END IF ! iCellsSpecial
350 
351  icellsspecial = icellsspecial + 1
352  pgrid%cellsSpecial(icellsspecial) = cellindx
353 
354  WRITE(stdout,'(A,9X,A,1X,I3)') solver_name, &
355  'Number of stencil members:', &
356  pgrid%c2cs1D(fndir,cellindx)%nCellMembs
357 
358  DO icl = 1,pgrid%c2cs1D(fndir,cellindx)%nCellMembs
359  icellsspecial = icellsspecial + 1
360 
361  IF ( icellsspecial == ncells_special_max ) THEN
362  CALL errorstop(global,err_ncells_special_max,__line__)
363  END IF ! iCellsSpecial
364 
365  pgrid%cellsSpecial(icellsspecial) = &
366  pgrid%c2cs1D(fndir,cellindx)%cellMembs(icl)
367  END DO ! icl
368  ELSE
369  global%warnCounter = global%warnCounter + 1
370 
371  WRITE(stdout,'(A,5X,A)') solver_name, &
372  '*** WARNING *** Invalid input.'
373  cycle
374  END IF ! cellIndx
375  CASE ( 2,3 )
376  IF ( ASSOCIATED(pgrid%c2cs) .EQV. .false. ) THEN
377  global%warnCounter = global%warnCounter + 1
378 
379  WRITE(stdout,'(A,7X,A)') solver_name, &
380  '*** WARNING *** Stencil not built.'
381  cycle
382  END IF ! ASSOCIATED
383 
384  WRITE(stdout,'(A,7X,A)') solver_name,'Enter cell index:'
385  READ(stdin,*,iostat=errorflag) cellindx
386 
387  IF ( cellindx > 0 .AND. cellindx <= pgrid%nCellsTot ) THEN
388  IF ( icellsspecial == ncells_special_max ) THEN
389  CALL errorstop(global,err_ncells_special_max,__line__)
390  END IF ! iCellsSpecial
391 
392  icellsspecial = icellsspecial + 1
393  pgrid%cellsSpecial(icellsspecial) = cellindx
394 
395  WRITE(stdout,'(A,9X,A,1X,I3)') solver_name, &
396  'Number of stencil members:',pgrid%c2cs(cellindx)%nCellMembs
397 
398  DO icl = 1,pgrid%c2cs(cellindx)%nCellMembs
399  icellsspecial = icellsspecial + 1
400 
401  IF ( icellsspecial == ncells_special_max ) THEN
402  CALL errorstop(global,err_ncells_special_max,__line__)
403  END IF ! iCellsSpecial
404 
405  pgrid%cellsSpecial(icellsspecial) = &
406  pgrid%c2cs(cellindx)%cellMembs(icl)
407  END DO ! icl
408  ELSE
409  global%warnCounter = global%warnCounter + 1
410 
411  WRITE(stdout,'(A,5X,A)') solver_name, &
412  '*** WARNING *** Invalid input.'
413  cycle
414  END IF ! cellIndx
415  CASE default
416  CALL errorstop(global,err_reached_default,__line__)
417  END SELECT ! pRegion%mixtInput%stencilDimensCells
418 
419 ! ------- Face stencil ---------------------------------------------------------
420 
421  CASE ( 'f' )
422  IF ( ASSOCIATED(pgrid%f2cs) .EQV. .false. ) THEN
423  global%warnCounter = global%warnCounter + 1
424 
425  WRITE(stdout,'(A,7X,A)') solver_name, &
426  '*** WARNING *** Stencil not built.'
427  cycle
428  END IF ! ASSOCIATED
429 
430  WRITE(stdout,'(A,7X,A)') solver_name,'Enter face index:'
431  READ(stdin,*,iostat=errorflag) faceindx
432 
433  IF ( faceindx > 0 .AND. faceindx <= pgrid%nFacesTot ) THEN
434  WRITE(stdout,'(A,9X,A,1X,I3)') solver_name, &
435  'Number of stencil members:',pgrid%f2cs(faceindx)%nCellMembs
436 
437  DO icl = 1,pgrid%f2cs(faceindx)%nCellMembs
438  icellsspecial = icellsspecial + 1
439 
440  IF ( icellsspecial == ncells_special_max ) THEN
441  CALL errorstop(global,err_ncells_special_max,__line__)
442  END IF ! iCellsSpecial
443 
444  pgrid%cellsSpecial(icellsspecial) = &
445  pgrid%f2cs(faceindx)%cellMembs(icl)
446  END DO ! icl
447  ELSE
448  global%warnCounter = global%warnCounter + 1
449 
450  WRITE(stdout,'(A,5X,A)') solver_name, &
451  '*** WARNING *** Invalid input.'
452  cycle
453  END IF ! cellIndx
454 
455 ! ------- Vertex stencil --------------------------------------------------------
456 
457  CASE ( 'v' )
458  IF ( ASSOCIATED(pgrid%v2cs) .EQV. .false. ) THEN
459  global%warnCounter = global%warnCounter + 1
460 
461  WRITE(stdout,'(A,7X,A)') solver_name, &
462  '*** WARNING *** Stencil not built.'
463  cycle
464  END IF ! ASSOCIATED
465 
466  WRITE(stdout,'(A,7X,A)') solver_name,'Enter vertex index:'
467  READ(stdin,*,iostat=errorflag) vertindx
468 
469  IF ( vertindx > 0 .AND. vertindx <= pgrid%nVertTot ) THEN
470  WRITE(stdout,'(A,9X,A,1X,I3)') solver_name, &
471  'Number of stencil members:',pgrid%v2cs(vertindx)%nCellMembs
472 
473  DO icl = 1,pgrid%v2cs(vertindx)%nCellMembs
474  icellsspecial = icellsspecial + 1
475 
476  IF ( icellsspecial == ncells_special_max ) THEN
477  CALL errorstop(global,err_ncells_special_max,__line__)
478  END IF ! iCellsSpecial
479 
480  pgrid%cellsSpecial(icellsspecial) = &
481  pgrid%v2cs(vertindx)%cellMembs(icl)
482  END DO ! icl
483  ELSE
484  global%warnCounter = global%warnCounter + 1
485 
486  WRITE(stdout,'(A,5X,A)') solver_name, &
487  '*** WARNING *** Invalid input.'
488  cycle
489  END IF ! cellIndx
490 
491 ! ------- Default --------------------------------------------------------------
492 
493  CASE default
494  global%warnCounter = global%warnCounter + 1
495 
496  WRITE(stdout,'(A,5X,A)') solver_name, &
497  '*** WARNING *** Invalid input.'
498  cycle
499  END SELECT ! stencilType
500 
501 ! ------------------------------------------------------------------------------
502 ! Cells meeting at vertex
503 ! ------------------------------------------------------------------------------
504 
505  CASE ( 'v' )
506  WRITE(stdout,'(A,5X,A)') solver_name,'Enter vertex index:'
507  READ(stdin,*,iostat=errorflag) vertindx
508 
509  IF ( errorflag /= err_none ) THEN
510  global%warnCounter = global%warnCounter + 1
511 
512  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
513  cycle
514  END IF ! errorFlag
515 
516  IF ( vertindx > 0 .AND. vertindx <= pgrid%nVertTot ) THEN
517 
518 ! ------- Tetrahedra -----------------------------------------------------------
519 
520  IF ( pgrid%nTetsTot > 0 ) THEN
521  WRITE(stdout,'(A,5X,A)') solver_name,'Tetrahedra...'
522 
523  nvertpercell = 4
524 
525  DO icl = 1,pgrid%nTetsTot
526  v(1:nvertpercell) = pgrid%tet2v(1:nvertpercell,icl)
527 
528  CALL quicksortinteger(v,nvertpercell)
529  CALL binarysearchinteger(v,nvertpercell,vertindx,iloc)
530 
531  IF ( iloc /= element_not_found ) THEN
532  IF ( icellsspecial == ncells_special_max ) THEN
533  CALL errorstop(global,err_ncells_special_max,__line__)
534  END IF ! iCellsSpecial
535 
536  icellsspecial = icellsspecial + 1
537  pgrid%cellsSpecial(icellsspecial) = pgrid%tet2CellGlob(icl)
538 
539  WRITE(stdout,'(A,7X,A,1X,I8)') solver_name,'Added cell:', &
540  pgrid%tet2CellGlob(icl)
541  END IF ! iloc
542  END DO ! icl
543  END IF ! pGrid%nTetsTot
544 
545 ! ------- Hexahedra ------------------------------------------------------------
546 
547  IF ( pgrid%nHexsTot > 0 ) THEN
548  WRITE(stdout,'(A,5X,A)') solver_name,'Hexahedra...'
549 
550  nvertpercell = 8
551 
552  DO icl = 1,pgrid%nHexsTot
553  v(1:nvertpercell) = pgrid%hex2v(1:nvertpercell,icl)
554 
555  CALL quicksortinteger(v,nvertpercell)
556  CALL binarysearchinteger(v,nvertpercell,vertindx,iloc)
557 
558  IF ( iloc /= element_not_found ) THEN
559  IF ( icellsspecial == ncells_special_max ) THEN
560  CALL errorstop(global,err_ncells_special_max,__line__)
561  END IF ! iCellsSpecial
562 
563  icellsspecial = icellsspecial + 1
564  pgrid%cellsSpecial(icellsspecial) = pgrid%hex2CellGlob(icl)
565 
566  WRITE(stdout,'(A,7X,A,1X,I8)') solver_name,'Added cell:', &
567  pgrid%hex2CellGlob(icl)
568  END IF ! iloc
569  END DO ! icl
570  END IF ! pGrid%nPyrsTot
571 
572 ! ------- Prisms ---------------------------------------------------------------
573 
574  IF ( pgrid%nPrisTot > 0 ) THEN
575  WRITE(stdout,'(A,5X,A)') solver_name,'Prisms...'
576 
577  nvertpercell = 6
578 
579  DO icl = 1,pgrid%nPrisTot
580  v(1:nvertpercell) = pgrid%pri2v(1:nvertpercell,icl)
581 
582  CALL quicksortinteger(v,nvertpercell)
583  CALL binarysearchinteger(v,nvertpercell,vertindx,iloc)
584 
585  IF ( iloc /= element_not_found ) THEN
586  IF ( icellsspecial == ncells_special_max ) THEN
587  CALL errorstop(global,err_ncells_special_max,__line__)
588  END IF ! iCellsSpecial
589 
590  icellsspecial = icellsspecial + 1
591  pgrid%cellsSpecial(icellsspecial) = pgrid%pri2CellGlob(icl)
592 
593  WRITE(stdout,'(A,7X,A,1X,I8)') solver_name,'Added cell:', &
594  pgrid%pri2CellGlob(icl)
595  END IF ! iloc
596  END DO ! icl
597  END IF ! pGrid%nPyrsTot
598 
599 ! ------- Pyramids -------------------------------------------------------------
600 
601  IF ( pgrid%nPyrsTot > 0 ) THEN
602  WRITE(stdout,'(A,5X,A)') solver_name,'Pyramids...'
603 
604  nvertpercell = 5
605 
606  DO icl = 1,pgrid%nPyrsTot
607  v(1:nvertpercell) = pgrid%pyr2v(1:nvertpercell,icl)
608 
609  CALL quicksortinteger(v,nvertpercell)
610  CALL binarysearchinteger(v,nvertpercell,vertindx,iloc)
611 
612  IF ( iloc /= element_not_found ) THEN
613  IF ( icellsspecial == ncells_special_max ) THEN
614  CALL errorstop(global,err_ncells_special_max,__line__)
615  END IF ! iCellsSpecial
616 
617  icellsspecial = icellsspecial + 1
618  pgrid%cellsSpecial(icellsspecial) = pgrid%pyr2CellGlob(icl)
619 
620  WRITE(stdout,'(A,7X,A,1X,I8)') solver_name,'Added cell:', &
621  pgrid%pyr2CellGlob(icl)
622  END IF ! iloc
623  END DO ! icl
624  END IF ! pGrid%nPyrsTot
625 
626  ELSE
627  global%warnCounter = global%warnCounter + 1
628 
629  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
630  cycle
631  END IF ! vertIndx
632 
633 ! ------------------------------------------------------------------------------
634 ! Quit
635 ! ------------------------------------------------------------------------------
636 
637  CASE ( 'q' )
638  EXIT
639 
640 ! ------------------------------------------------------------------------------
641 ! Default
642 ! ------------------------------------------------------------------------------
643 
644  CASE default
645  global%warnCounter = global%warnCounter + 1
646 
647  WRITE(stdout,'(A,5X,A)') solver_name,'*** WARNING *** Invalid input.'
648  cycle
649  END SELECT
650  END DO ! <empty>
651 
652 ! ******************************************************************************
653 ! Set number of special cells
654 ! ******************************************************************************
655 
656  pgrid%nCellsSpecial = icellsspecial
657 
658 ! ******************************************************************************
659 ! End
660 ! ******************************************************************************
661 
662  IF ( global%verbLevel > verbose_none ) THEN
663  WRITE(stdout,'(A,1X,A)') solver_name,'Picking special cells done.'
664  END IF ! global%verbLevel
665 
666  CALL deregisterfunction(global)
667 
668 END SUBROUTINE rflu_pickspecialcells
669 
670 ! ******************************************************************************
671 !
672 ! RCS Revision history:
673 !
674 ! $Log: RFLU_PickSpecialCells.F90,v $
675 ! Revision 1.11 2008/12/06 08:45:04 mtcampbe
676 ! Updated license.
677 !
678 ! Revision 1.10 2008/11/19 22:18:15 mtcampbe
679 ! Added Illinois Open Source License/Copyright
680 !
681 ! Revision 1.9 2007/02/27 13:18:17 haselbac
682 ! Enabled 1d computations
683 !
684 ! Revision 1.8 2006/04/07 14:56:41 haselbac
685 ! Adapted to new stencilDimens param
686 !
687 ! Revision 1.7 2006/01/06 22:18:16 haselbac
688 ! Added treatment of 1d stencils
689 !
690 ! Revision 1.6 2005/01/10 19:37:42 haselbac
691 ! Added capability of picking boundary-face stencils
692 !
693 ! Revision 1.5 2004/12/27 23:33:17 haselbac
694 ! Added writing of number of stencil members
695 !
696 ! Revision 1.4 2004/10/19 19:30:09 haselbac
697 ! Added checks for existence of stencils
698 !
699 ! Revision 1.3 2004/02/13 03:02:10 haselbac
700 ! Added stencils to selection
701 !
702 ! Revision 1.2 2003/07/22 02:08:33 haselbac
703 ! Added global%warnCounter
704 !
705 ! Revision 1.1.1.1 2003/06/04 22:31:20 haselbac
706 ! Initial revision
707 !
708 ! ******************************************************************************
709 
710 
711 
712 
713 
714 
715 
rflu_modgrid
Definition: RFLU_ModGrid.F90:39
moderror::registerfunction
subroutine registerfunction(global, funName, fileName)
Definition: ModError.F90:449
modgrid::t_grid
Definition: ModGrid.F90:56
modsortsearch::quicksortinteger
subroutine quicksortinteger(a, n)
Definition: ModSortSearch.F90:482
modsortsearch::binarysearchinteger
subroutine binarysearchinteger(a, n, v, i, j)
Definition: ModSortSearch.F90:98
v
*********************************************************************Illinois Open Source License ****University of Illinois NCSA **Open Source License University of Illinois All rights reserved ****Developed free of to any person **obtaining a copy of this software and associated documentation to deal with the Software without including without limitation the rights to and or **sell copies of the and to permit persons to whom the **Software is furnished to do subject to the following this list of conditions and the following disclaimers ****Redistributions in binary form must reproduce the above **copyright this list of conditions and the following **disclaimers in the documentation and or other materials **provided with the distribution ****Neither the names of the Center for Simulation of Advanced the University of nor the names of its **contributors may be used to endorse or promote products derived **from this Software without specific prior written permission ****THE SOFTWARE IS PROVIDED AS WITHOUT WARRANTY OF ANY **EXPRESS OR INCLUDING BUT NOT LIMITED TO THE WARRANTIES **OF FITNESS FOR A PARTICULAR PURPOSE AND **NONINFRINGEMENT IN NO EVENT SHALL THE CONTRIBUTORS OR **COPYRIGHT HOLDERS BE LIABLE FOR ANY DAMAGES OR OTHER WHETHER IN AN ACTION OF TORT OR **ARISING OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE **USE OR OTHER DEALINGS WITH THE SOFTWARE v
Definition: roccomf90.h:20
rflu_pickspecialcells
subroutine rflu_pickspecialcells(pRegion)
Definition: RFLU_PickSpecialCells.F90:44
modglobal::t_global
Definition: ModGlobal.F90:50
moderror::errorstop
subroutine errorstop(global, errorCode, errorLine, addMessage)
Definition: ModError.F90:483
moderror::deregisterfunction
subroutine deregisterfunction(global)
Definition: ModError.F90:469
modbndpatch::t_patch
Definition: ModBndPatch.F90:91