wrmtak
C WRMTAK SOURCE PV 17/12/05 21:17:29 9646 IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C*********************************************************************** C NOM : WRMTAK C DESCRIPTION : Ecriture des objets de type MATRAK sur le C fichier IFSAU C (appelé par wrpil.eso) C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES (E/S) : ECDIFE (ecriture d'un tableau d'entiers) C ECDIFR (ecriture d'un tableau de REAL*8) C*********************************************************************** C SYNTAXE GIBIANE : SAUV C ENTREES : IFSAU, numéro du fichier en écriture C IDEB, IMAX1, indice de début et de fin C de la pile des objets MATRAK (ITLACC) C à écrire. C IFORM, le fichier a ecrire est formaté ou C non. C*********************************************************************** C VERSION : v1, 15/07/98, version initiale C HISTORIQUE : v1, 15/07/98, création C HISTORIQUE : C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** -INC PPARAM -INC CCOPTIO C-INC SMMATRAKANC C************************************************************************* C C REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES puis assemblees C * LGEOC SPG de la pression et/ou des multiplicateurs de Lagrange * (points CENTRE ) pour chaque operateur de contrainte * KGEOC SPG pour la totalite des points CENTRE. * KGEOS SPG pour la totalite des points SOMMET (Diagonale vitesse) * KLEMC Connectivites de l'ensemble des contraintes * LIZAFM(NBSOUS) contient les pointeurs IZAFM des sous-zones SEGMENT MATRAK INTEGER LGEOC(NBOP),IDEBS(NBOP),IFINS(NBOP) INTEGER LIZAFM(NBSOUS) INTEGER IKAM0 (NBSOUS) INTEGER IMEM (NBELC) INTEGER KLEMC,KGEOS,KGEOC,KDIAG,KCAC,KIZCL,KIZGC ENDSEGMENT SEGMENT IZAFM REAL*8 AM(NNELP,NP,IESP),RPGI(NELAX) ENDSEGMENT C************************************************************************* -INC SMMATRK1 -INC TMCOLAC SEGMENT IZA REAL*8 A(NBVA) ENDSEGMENT C INTEGER NDTAB INTEGER IEL,I INTEGER ILENA(7) C====================================================================== * * Executable statements * C C ... BOUCLE SUR LES MATRAK DE LA PILE DO 1 IEL=IDEB,IMAX1 MATRAK=ITLAC(IEL) IF (MATRAK.EQ.0) THEN WRITE(IOIMP,*) 'Failing to save a nil pointer' WRITE(IOIMP,*) 'MATRAK type object...' GOTO 9999 ENDIF C Sauvegarde du chapeau C Dimensions SEGACT MATRAK NBOP =LGEOC(/1) NBSOUS=LIZAFM(/1) NBELC =IMEM(/1) ILENA(1)=NBOP ILENA(2)=NBSOUS ILENA(3)=NBELC NDTAB=3 C Rigidités élémentaires NDTAB=NBOP NDTAB=NBOP NDTAB=NBOP NDTAB=NBSOUS NDTAB=NBSOUS NDTAB=NBELC ILENA( 1)=KLEMC ILENA( 2)=KGEOS ILENA( 3)=KGEOC ILENA( 4)=KDIAG ILENA( 5)=KCAC ILENA( 6)=KIZCL ILENA( 7)=KIZGC NDTAB=7 C Sauvegarde des IZAFM DO 11 I=1,NBSOUS IZAFM=LIZAFM(I) IF (IZAFM.NE.0) THEN SEGACT IZAFM NNELP=AM(/1) NP =AM(/2) IESP =AM(/3) NELAX=RPGI(/1) ILENA(1)=NNELP ILENA(2)=NP ILENA(3)=IESP ILENA(4)=NELAX NDTAB=4 NDTAB=NNELP*NP*IESP NDTAB=NELAX SEGDES IZAFM ENDIF 11 CONTINUE C Sauvegarde du IZL IF (KIZCL.NE.0) THEN IZL=KIZCL SEGACT IZL C Dimensions NJA=KZA(/1) NJAN=NUAN(/1) NJAB=B(/1) ILENA(1)=NJA ILENA(2)=NJAN ILENA(3)=NJAB ILENA(4)=KZA1 NDTAB=4 C Contenu des tableaux NDTAB=NJA NDTAB=NJAN NDTAB=NJAN NDTAB=NJAN NDTAB=NJAN NDTAB=NJAB C Sauvegarde du IDMAT IF (KZA1.NE.0) THEN IDMAT=KZA1 SEGACT IDMAT C Dimension NBLK=IDESCR(/1) ILENA(1)=NBLK ILENA(2)=IDIAG NDTAB=2 NDTAB=NBLK NDTAB=NBLK+1 IF (IDIAG.NE.0) THEN IZA=IDIAG SEGACT IZA NBVA=A(/1) ILENA(1)=NBVA NDTAB=1 NDTAB=NBVA SEGDES IZA ENDIF C Sauvegarde des IDBLK DO 211 INBLK=1,NBLK IDBLK=IDESCR(INBLK) IF (IDBLK.NE.0) THEN SEGACT IDBLK C Dimension NLBLK=IDEBLK(/1)-1 ILENA(1)=NLBLK ILENA(2)=IMAT ILENA(3)=ILON NDTAB=3 NDTAB=NLBLK+1 IF (IMAT.NE.0) THEN IZA=IMAT SEGACT IZA NBVA=A(/1) ILENA(1)=NBVA NDTAB=1 NDTAB=NBVA SEGDES IZA ENDIF SEGDES IDBLK ENDIF 211 CONTINUE SEGDES IDMAT ENDIF SEGDES IZL ENDIF SEGDES MATRAK 1 CONTINUE * * Normal termination * RETURN * * Format handling * * * Error handling * 9999 CONTINUE WRITE(IOIMP,*) 'An error was detected in subroutine wrmtak' RETURN * * End of subroutine WRMTIK * END
© Cast3M 2003 - Tous droits réservés.
Mentions légales