1 : C MKCOOR SOURCE CHAT 07/10/29 21:24:23 5940 2 : SUBROUTINE MKCOOR(CGEOME,MDISCR, 3 : $ MYFALS, 4 : $ ICOOR, 5 : $ IMPR,IRET) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : IMPLICIT INTEGER (I-N) 8 : C*********************************************************************** 9 : C NOM : MKCOOR 10 : C PROJET : Noyau linéaire NLIN 11 : C DESCRIPTION : On crée le champ par éléments contenant les coordonnées 12 : C des points servant pour la transformation géométrique 13 : C (ddl de la transformation géométrique)... 14 : C 15 : C LANGAGE : ESOPE 16 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 17 : C mél : gounand@semt2.smts.cea.fr 18 : C*********************************************************************** 19 : C APPELES : KEEF (recherche de l'élément fini) 20 : C NOMINC (nommage des inconnues) 21 : C MKCOO1 (remplissage du sous-champ par élément 22 : C (fortran 77)) 23 : C PRCAEL (impression du champ créé) 24 : C APPELE PAR : PRNLI2 25 : C*********************************************************************** 26 : C ENTREES : * CGEOME (type MELEME) : maillage de QUAFs 27 : C partitionné. 28 : C * MDISCR (type CH*(*)) : nom d'espace de 29 : C discrétisation (cf. NOMFA dans l'include 30 : C SFALRF) 31 : C * MYFALS (type FALRFS) : segment de description 32 : C des familles d'éléments de références. 33 : C SORTIES : * ICOOR (type MCHAEL) : champ par éléments de 34 : C coordonnées de points (degrés de liberté de la 35 : C transformation géométrique). 36 : C TRAVAIL : * SOUGEO (type MELEME) : maillage élémentaire. 37 : C * JCOOR (type MCHEVA) : valeurs du champ ICOOR 38 : C sur le maillage élémentaire. 39 : C Structure (cf.include SMCHAEL) : 40 : C (1, nb. ddl, 1, dim. esp. réel, 1, nb. élément) 41 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 42 : C*********************************************************************** 43 : C VERSION : v1, 01/09/99, version initiale 44 : C HISTORIQUE : v1, 01/09/99, création 45 : C HISTORIQUE : 46 : C HISTORIQUE : 47 : C*********************************************************************** 48 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 49 : C en cas de modification de ce sous-programme afin de faciliter 50 : C la maintenance ! 51 : C*********************************************************************** 52 : -INC CCOPTIO 53 : -INC CCGEOME 54 : -INC SMCOORD 55 : -INC SMELEME 56 : POINTEUR CGEOME.MELEME 57 : POINTEUR SOUGEO.MELEME 58 : * Segments à moi 59 : CBEGININCLUDE SMCHAEL 60 : SEGMENT MCHAEL 61 : POINTEUR IMACHE(N1).MELEME 62 : POINTEUR ICHEVA(N1).MCHEVA 63 : ENDSEGMENT 64 : SEGMENT MCHEVA 65 : REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM) 66 : ENDSEGMENT 67 : SEGMENT LCHEVA 68 : POINTEUR LISCHE(NBCHE).MCHEVA 69 : ENDSEGMENT 70 : CENDINCLUDE SMCHAEL 71 : INTEGER N1 72 : POINTEUR ICOOR.MCHAEL 73 : INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM 74 : POINTEUR JCOOR.MCHEVA 75 : CBEGININCLUDE SFALRF 76 : SEGMENT FALRF 77 : CHARACTER*(LNNFA) NOMFA 78 : INTEGER NUQUAF(NBLRF) 79 : POINTEUR ELEMF(NBLRF).ELREF 80 : ENDSEGMENT 81 : SEGMENT FALRFS 82 : POINTEUR LISFA(0).FALRF 83 : ENDSEGMENT 84 : CENDINCLUDE SFALRF 85 : POINTEUR MYFALS.FALRFS 86 : CBEGININCLUDE SELREF 87 : SEGMENT ELREF 88 : CHARACTER*(LNNOM) NOMLRF 89 : CHARACTER*(LNFORM) FORME 90 : CHARACTER*(LNTYPL) TYPEL 91 : CHARACTER*(LNESP) ESPACE 92 : INTEGER DEGRE 93 : REAL*8 XCONOD(NDIMEL,NBNOD) 94 : INTEGER NPQUAF(NBDDL) 95 : INTEGER NUMCMP(NBDDL) 96 : INTEGER QUENOD(NBDDL) 97 : INTEGER ORDDER(NDIMEL,NBDDL) 98 : POINTEUR MBPOLY.POLYNS 99 : ENDSEGMENT 100 : SEGMENT ELREFS 101 : POINTEUR LISEL(0).ELREF 102 : ENDSEGMENT 103 : CENDINCLUDE SELREF 104 : POINTEUR MYLRF.ELREF 105 : * 106 : CHARACTER*(*) MDISCR 107 : INTEGER IMPR,IRET 108 : * 109 : INTEGER ISOUS 110 : INTEGER NSOUS,NNOEU,NELEM,NDDL,NXCO 111 : INTEGER ITQUAF 112 : * 113 : * Executable statements 114 : * 115 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans mkcoor' 116 : SEGACT CGEOME 117 : NSOUS=CGEOME.LISOUS(/1) 118 : N1=NSOUS 119 : SEGINI ICOOR 120 : NXCO=MCOORD.XCOOR(/1) 121 : * Par sous-domaine... 122 : DO 1 ISOUS=1,NSOUS 123 : SOUGEO=CGEOME.LISOUS(ISOUS) 124 : SEGACT SOUGEO 125 : * On cherche l'élément fini correspondant au QUAF 126 : ITQUAF=SOUGEO.ITYPEL 126 : CALL KEEF(ITQUAF,MDISCR, 127 : $ MYFALS, 128 : $ MYLRF, 129 : $ IMPR,IRET) 130 : IF (IRET.NE.0) GOTO 9999 131 : SEGACT MYLRF 132 : NDDL=MYLRF.NPQUAF(/1) 133 : NNOEU=SOUGEO.NUM(/1) 134 : NELEM=SOUGEO.NUM(/2) 135 : NBLIG=1 136 : NBCOL=NDDL 137 : N2LIG=1 138 : N2COL=IDIM 139 : NBPOI=1 140 : NBELM=NELEM 141 : SEGINI JCOOR 141 : CALL MKCOO1(NNOEU,NELEM,NXCO,NDDL,IDIM, 142 : $ SOUGEO.NUM,MCOORD.XCOOR,MYLRF.NPQUAF, 143 : $ JCOOR.VELCHE, 144 : $ IMPR,IRET) 145 : IF (IRET.NE.0) GOTO 9999 146 : SEGDES JCOOR 147 : ICOOR.ICHEVA(ISOUS)=JCOOR 148 : SEGDES MYLRF 149 : SEGDES SOUGEO 150 : ICOOR.IMACHE(ISOUS)=SOUGEO 151 : 1 CONTINUE 152 : SEGDES ICOOR 153 : SEGDES CGEOME 154 : IF (IMPR.GT.3) THEN 155 : WRITE(IOIMP,*) 'On a créé', 156 : $ ' ICOOR(élément ,1, coor.esp ,1, ddl ,1)=',ICOOR 156 : CALL PRCAEL(ICOOR,IMPR,IRET) 157 : IF (IRET.NE.0) GOTO 9999 158 : ENDIF 159 : * 160 : * Normal termination 161 : * 162 : IRET=0 163 : RETURN 164 : * 165 : * Format handling 166 : * 167 : * 168 : * Error handling 169 : * 170 : 9999 CONTINUE 171 : IRET=1 172 : WRITE(IOIMP,*) 'An error was detected in subroutine mkcoor' 173 : RETURN 174 : * 175 : * End of subroutine MKCOOR 176 : * 177 : END 178 : 179 : 180 :
© Cast3M 2003 - All rights reserved.
Disclaimer