1 : C H8RCG2 SOURCE CHAT 06/03/29 21:23:00 5360 2 : C 3 : C 4 : C 5 : SUBROUTINE H8RCG2(IGR1,NBLIG1,NBCOL1, 6 : > IGR2,NBLIG2,NBCOL2,COORD,NBCOOR,IDIMC,NBCOUC,RAISON, 7 : > ITVL,NITMAX, 8 : > ITRNOE,NBNMAX,NBE,NBP, 9 : > NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr) 10 : C ********************************************************************** 11 : C OBJET H8RCG2 : MAILLAGE H8 RACCORDANT 2 GRILLES COMPATIBLES 12 : C OBJET EN 1 COUCHE MINI.(NBCOL2 >= NBCOL1,NBLIG2 <= NBLIG1) 13 : C 14 : C LES GRILLES IGR1 ET IGR2 SONT ORIENTEES DE LA MEME FACON 15 : C AVEC UNE ORIGINE COMPATIBLE IGR1(1) CORRESPOND A IGR2(1) 16 : C ET AVEC NBCOL2 >= NBCOL1 ET NBLIG2 <= NBLIG1 17 : C 18 : C APPELS : H8RCGI 19 : C 20 : C EN ENTREE : 21 : C 22 : C IGR1,NBLIG1,NBCOL1 : LA PREMIERE GRILLE 23 : C IGR CONTIENT LES NUMEROS DES NOEUDS 24 : C IGR2,NBLIG2,NBCOL2 : LA DEUXIEME GRILLE 25 : C NBCOUC : NOMBRE DE COUCHES SUPPLEMENTAIRES 26 : C (PAR DEFAUT 1 SEULE COUCHE) 27 : C 28 : C COORD,IDIMC : POSITION DES NOEUDS 29 : C 30 : C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS 31 : C NITMAX : TAILLE DE ITVL, LA PLACE NECESSAIRE EST DE 32 : C NBLIG1*NBCOL2*NBRAN SI ICOMPR= 0 33 : C SINON IL FAUT AJOUTER : NBLIG3*NBCOL3*(NBRAN3-2) + NBCOOR 34 : C AVEC NBRAN = (3+NBCOUC+NBCOL2+NBLIG2-NBCOL1-NBLIG1) 35 : C 36 : C ITRNOE : TABLEAU DES ELEMENTS (A REMPLIR) 37 : C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS 38 : C NBNMAX : NOMBRE MAXIMUM DE NOEUDS (LIE A LA TAILLE DE COORD) 39 : C 40 : C ICOMPR : FLAG DE COMPRESSION 41 : C ICOMPR = 0 LES NOEUDS ISOLES NE SONT PAS SUPPRIMES 42 : C LES ELEMENTS NULS " " " " 43 : C 44 : C EN SORTIE : 45 : C 46 : C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NBP : LE MAILLAGE RESULTANT 47 : C iarr : CODE D'ERREUR -1 SI DONNEES INCORRECTES 48 : C -2 SI TABLEAUX INSUFFISANTS 49 : C 50 : C REMARQUE : L'ALGORITHME GENERE LES NOEUDS D'UNE GRILLE COMPLETE 51 : C APRES LE COUPER-COLLER CERTAIN NOEUDS DEVIENDRONT ISOLES 52 : C ET CERTAIN ELEMENTS SERONT NON VALIDES (NULS). 53 : C LE FLAG "ICOMPR" PERMET DE LES SUPPRIMER 54 : C ********************************************************************** 55 : IMPLICIT INTEGER(I-N) 56 : INTEGER IGR1(*),NBLIG1,NBCOL1 57 : INTEGER IGR2(*),NBLIG2,NBCOL2 58 : REAL*8 COORD(*),RAISON 59 : INTEGER IDIMC,NBCOOR,NBCOUC,ITVL(*),NITMAX 60 : INTEGER ITRNOE(*),NBNMAX,NBE,NBP 61 : INTEGER NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr 62 : C 63 : INTEGER NBCO11,NBCO22,NBCOL3,NBLG11,NBLG22,NBLIG3,NBRAN3 64 : INTEGER IGR11,IGR22 65 : INTEGER IARETE(4),NARETE(4) 66 : INTEGER INDICE,INCREM 67 : INTEGER NBCOAJ(2),INCOAJ(2),NBLGAJ(2),INLGAJ(2),NBAJ(2) 68 : INTEGER ITRAV 69 : C 70 : C =============================================== 71 : C --- 0. VERIFICATIONS DES CONDITIONS D'APPLICATION --- 72 : C =============================================== 73 : NBE = 0 74 : IF((NBCOL1.GT.NBCOL2).OR.(NBLIG2.GT.NBLIG1))THEN 75 : iarr = -1 75 : CALL DSERRE(1,iarr,'H8RCG2',' INVERSER LES 2 GRILLES ') 76 : GOTO 9999 77 : ENDIF 78 : C 79 : IF( ( MOD(NBCOL1+NBCOL2,2).NE.0 ).OR. 80 : > ( MOD(NBLIG1+NBLIG2,2).NE.0 ))THEN 81 : iarr = -1 81 : CALL DSERRE(1,iarr,'H8RCG2', 82 : > ' PARITE : UNE COUCHE INSUFFISANTE ') 83 : GOTO 9999 84 : ENDIF 85 : C 86 : IF(((NBCOL1.LT.NBCOL2).AND.(NBLIG1.LT.NBLIG2)).OR. 87 : > ((NBCOL1.GT.NBCOL2).AND.(NBLIG1.GT.NBLIG2)))THEN 88 : iarr = -1 88 : CALL DSERRE(1,iarr,'H8RCG2',' DEUX COUCHES NECESSAIRES ') 89 : GOTO 9999 90 : ENDIF 91 : C 92 : IARETE(1) = 7 93 : IARETE(2) = 8 94 : IARETE(3) = 10 95 : IARETE(4) = 2 96 : NARETE(1) = ( NBCOL2 - NBCOL1 ) / 2 97 : NARETE(2) = ( NBCOL2 - NBCOL1 ) / 2 98 : NARETE(3) = ( NBLIG1 - NBLIG2 ) / 2 99 : NARETE(4) = ( NBLIG1 - NBLIG2 ) / 2 100 : C 101 : NBLIG3 = NBCOL2 102 : NBCOL3 = NARETE(1)+NARETE(3)+2 +NBCOUC-1 103 : NBRAN3 = NBLIG1 104 : C 105 : NBE = (NBLIG3-1)*(NBCOL3-1)*(NBRAN3-1) 106 : NBP = NBLIG3*NBCOL3*NBRAN3 107 : IF((NBEMAX.LT.NBE).OR.(NBPMAX.LT.NBP))THEN 108 : iarr = -2 108 : CALL DSERRE(1,iarr,'H8RCG2',' POUR LE MAILLAGE 3D ') 108 : CALL ESEINT(1,'PLACE NECESSAIRE POUR LES ELEMENTS',NBEMAX,1) 108 : CALL ESEINT(1,'PLACE NECESSAIRE POUR LES NOEUDS',NBPMAX,1) 109 : GOTO 9999 110 : ENDIF 111 : C ============================ 112 : C --- 1. CREATION DES GRILLES 2D --- 113 : C ============================ 114 : C ------------------------------------- 115 : C --- ON COMPLETE LES GRILLES A RACCORDER --- 116 : C ------------------------------------- 117 : C (NBLIG1',NBCOL1') = (NBLIG2',NBCOL2') 118 : C 119 : IF(ITRACE.GT.0) 119 : > CALL ESECHA(1,'1. ON COMPLETE DES GRILLES SURFACIQUES : ',' ') 120 : C 121 : INDICE = NBCOOR+1 122 : INCREM = 1 123 : IF(ITRACE.GT.0)THEN 123 : CALL ESECHA(1,'-> NOUVEAUX NOEUDS',' ') 123 : CALL ESEINT(1,'A PARTIR DU NUMERO ',INDICE,1) 124 : ENDIF 125 : C 126 : C --- ON AJOUTE DES COLONNES A GR1 --- 127 : C 128 : NBAJ(1) = 2 129 : NBAJ(2) = 0 130 : INCOAJ(1) = 1 131 : NBCOAJ(1) = (NBCOL2-NBCOL1) / 2 132 : NBCOAJ(2) = (NBCOL2-NBCOL1) / 2 133 : INCOAJ(2) = -NBCOL1 134 : C 135 : IGR11 = 1 136 : ITRAV = 1 137 : IF( NITMAX.LT. (IGR11-1+ NBCOL2*NBLIG1))THEN 138 : iarr = -2 138 : CALL DSERRE(1,iarr,'H8RCG2',' POUR COMPLETER LA GRILLE ') 138 : CALL ESEINT(1,'PLACE NECESSAIRE ',NBCOL2*NBLIG1,1) 139 : GOTO 9999 140 : ENDIF 141 : C 141 : CALL G2POLC(IGR1,NBLIG1,NBCOL1, 142 : > NBAJ,NBCOAJ,INCOAJ,NBLGAJ,INLGAJ, 143 : > INDICE,INCREM,COORD,NBCOOR,IDIMC, 144 : > ITVL(ITRAV),0, 145 : > ITVL(IGR11),NBLG11,NBCO11,iarr) 146 : IF(iarr.NE.0)THEN 146 : CALL DSERRE(1,iarr,'H8RCG2',' APPEL G2POLC ') 147 : GOTO 9999 148 : ENDIF 149 : C 150 : IF(ITRACE.GT.0)THEN 150 : CALL ESECHA(1,'-> GRILLE 1 COMPLETEE',' ') 150 : CALL ESEINT(1,'COLONNES ',NBCO11,1) 150 : CALL ESEINT(1,'LIGNES ',NBLG11,1) 151 : ENDIF 152 : C 153 : C --- ON AJOUTE DES LIGNES A GR2 --- 154 : C 155 : NBAJ(1) = 0 156 : NBAJ(2) = 2 157 : INLGAJ(1) = 1 158 : NBLGAJ(1) = (NBLIG1-NBLIG2) / 2 159 : NBLGAJ(2) = (NBLIG1-NBLIG2) / 2 160 : INLGAJ(2) = -NBLIG2 161 : C 162 : IGR22 = IGR11 + NBLIG1*NBCOL2 163 : IF( NITMAX.LT. (IGR22-1+ NBLIG1*NBCOL2))THEN 164 : iarr = -2 164 : CALL DSERRE(1,iarr,'H8RCG2',' POUR COMPLETER LA GRILLE ') 164 : CALL ESEINT(1,'PLACE NECESSAIRE ', 165 : > IGR22-1+NBLIG1*NBCOL2,1) 166 : GOTO 9999 167 : ENDIF 168 : C 168 : CALL G2POLC(IGR2,NBLIG2,NBCOL2, 169 : > NBAJ,NBCOAJ,INCOAJ,NBLGAJ,INLGAJ, 170 : > INDICE,INCREM,COORD,NBCOOR,IDIMC, 171 : > ITVL(ITRAV),0, 172 : > ITVL(IGR22),NBLG22,NBCO22,iarr) 173 : IF(iarr.NE.0)THEN 173 : CALL DSERRE(1,iarr,'H8RCG2',' APPEL G2POLC ') 174 : GOTO 9999 175 : ENDIF 176 : C 177 : IF(ITRACE.GT.0)THEN 177 : CALL ESECHA(1,'-> GRILLE 2 COMPLETEE',' ') 177 : CALL ESEINT(1,'COLONNES ',NBCO22,1) 177 : CALL ESEINT(1,'LIGNES ',NBLG22,1) 178 : ENDIF 179 : C ============================ 180 : C --- 2. CREATION DU RACCORD 3D --- 181 : C ============================ 182 : C 183 : NBCOOR = INDICE - 1 184 : ITRAV = IGR22 + NBLIG1*NBCOL2 185 : IF( NBLIG3*NBCOL3*NBRAN3 .GT. (NITMAX-ITRAV+1))THEN 186 : iarr = -2 186 : CALL DSERRE(1,iarr,'H8RCG2',' POUR LE RACCORD ') 186 : CALL ESEINT(1,'PLACE NECESSAIRE ', 187 : > NBLIG3*NBCOL3*NBRAN3+ITRAV,1) 188 : GOTO 9999 189 : ENDIF 189 : CALL H8RCGI(ITVL(IGR11),NBLG11,NBCO11, 190 : > ITVL(IGR22),NBLG22,NBCO22, 191 : > COORD,NBCOOR,IDIMC,NBCOUC,RAISON, 192 : > NBLIG3,NBCOL3,NBRAN3,IARETE,NARETE, 193 : > ITVL(ITRAV),(NITMAX-ITRAV+1), 194 : > ITRNOE,NBNMAX,NBE,NBP, 195 : > NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr) 196 : C 197 : C 198 : 9999 END 199 : 200 : 201 :
© Cast3M 2003 - All rights reserved.
Disclaimer