1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
*DECK NXTMCC
SUBROUTINE NXTMCC(IPTRK,NAMCEL,NREGC,NSURC,NREGF,NSURF,INDEX,
1 IDSUR,IDREG)
*-----------------------------------------------------------------------
*
*Purpose:
* Calculate and store the compressed index and region/surface ids for
* an elementary geometry.
*
*Copyright:
* Copyright (C) 2008 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): Romain Le Tellier
*
*Parameters: input
* IPTRK pointer to the TRACKING data structure.
* NAMCEL name of the elementary geometry to be treated.
* NREGC number of regions (uncompressed).
* NSURC number of surfaces (uncompressed).
*
*Parameters: output
* NREGF number of regions (compressed).
* NSURF number of surfaces (compressed).
*
*Parameters: input/output
* INDEX index vector (uncompressed and compressed).
* IDSUR surface identificator (uncompressed and compressed).
* IDREG region identificator (uncompressed and compressed).
*
*-----------------------------------------------------------------------
*
USE GANLIB
IMPLICIT NONE
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPTRK
* INTEGER IPTRK
INTEGER NREGC,NSURC,NREGF,NSURF,INDEX(5,-NSURC:NREGC,2),
1 IDSUR(NSURC,2),IDREG(NREGC,2)
CHARACTER NAMCEL*9
*----
* LOCAL VARIABLES
*----
INTEGER NSTATE,IOUT
PARAMETER(NSTATE=40,IOUT=6)
INTEGER ESTATE(NSTATE)
INTEGER I,ISUR,INDF,JJ,ITMP,IREG
CHARACTER NAMREC*12
*----
* SCAN THE SURFACES AND FILL IN THE SURFACE ID AND CORREPONDING INDEX
*----
NSURF=0
INDF=-NSURC-1
DO I=NSURC,1,-1
ISUR=IDSUR(I,1)
IF (IDSUR(I,1).NE.0) THEN
NSURF=NSURF+1
IDSUR(NSURF,2)=ABS(ISUR)
INDF=INDF+1
DO JJ=1,4
INDEX(JJ,INDF,2)=INDEX(JJ,-I,1)
ENDDO
ENDIF
ENDDO
*----
* REVERSE SURFACE ID IN SUCH A WAY THAT
* IDSUR(I,2) CORRESPONDS TO INDEX(:,-NSURC+NSURF-I,2)
*----
DO I=1,NSURF/2
ITMP=IDSUR(NSURF+1-I,2)
IDSUR(NSURF+1-I,2)=IDSUR(I,2)
IDSUR(I,2)=ITMP
ENDDO
INDF=INDF+1
DO JJ=1,4
INDEX(JJ,INDF,2)=0
ENDDO
*----
* SCAN THE REGIONS AND FILL IN THE SURFACE ID AND CORREPONDING INDEX
*----
NREGF=0
DO I=1,NREGC
IREG=IDREG(I,1)
IF (IDREG(I,1).NE.0) THEN
NREGF=NREGF+1
IDREG(NREGF,2)=ABS(IREG)
INDF=INDF+1
DO JJ=1,4
INDEX(JJ,INDF,2)=INDEX(JJ,I,1)
ENDDO
ENDIF
ENDDO
*----
* STORE THE FINAL NUMBER OF REGIONS/SURFACES
* AND THE COMPRESSED IDS AND INDEX
*----
NAMREC=NAMCEL//'DIM'
ESTATE(:NSTATE)=0
CALL LCMGET(IPTRK,NAMREC,ESTATE)
ESTATE(39)=NREGF
ESTATE(40)=NSURF
CALL LCMPUT(IPTRK,NAMREC,NSTATE,1,ESTATE)
IF (NREGF.GT.0) THEN
NAMREC=NAMCEL//'RIC'
CALL LCMPUT(IPTRK,NAMREC,NREGF,1,IDREG(1,2))
ENDIF
IF (NSURF.GT.0) THEN
NAMREC=NAMCEL//'SIC'
CALL LCMPUT(IPTRK,NAMREC,NSURF,1,IDSUR(1,2))
ENDIF
INDF=NREGF+NSURF+1
IF (INDF.GT.0) THEN
NAMREC=NAMCEL//'VSC'
CALL LCMPUT(IPTRK,NAMREC,5*INDF,1,INDEX(1,-NSURC,2))
ENDIF
*
RETURN
END
|
