SUBROUTINE ADD999(ISWT9,NELC) ! add type 999 elements to all 1-d elements USE BLK1MOD USE BLK2MOD COMMON ISEQ(4000,10),LIST1(2000),LIST2(2000),J1OLD(20),J2OLD(20) INCLUDE 'TXFRM.COM' IF(.NOT. ALLOCATED(IUSEDM)) THEN ALLOCATE (IUSEDM(MAXE)) IUSEDM=0 ENDIF IF(.NOT. ALLOCATED(HSET)) THEN ISWTH=0 ELSE ISWTH=1 ENDIF ! loop on elements looking for 1-d PI2=3.14159/2. NTEMPLC=0 NCM=MAXECON NCMi=MAXECON IUSEDM=0 DO N=1,NE IF(IMAT(N) .NE. 999) CYCLE CALL KCON(0) GO TO 75 ENDDO GO TO 90 75 CONTINUE DO N=1,NE IF(IMAT(N) .EQ. 999) THEN DO J=1,NCMi IF(NCORN(ICON(N,J)) .EQ. 3) THEN M=ICON(N,J) IF(NOP(M,1) .EQ. NOP(N,1) .AND. NOP(M,3) .EQ. NOP(N,3) .OR.& NOP(M,1) .EQ. NOP(N,3) .AND. NOP(M,3) .EQ. NOP(N,1)) THEN IUSEDM(ICON(N,J))=1 GO TO 80 ENDIF ENDIF ENDDO ENDIF 80 CONTINUE ENDDO 90 n=1 ICL=0 do k=1,10 iseqp=2000 iseqm=2000 do ns=n,ne if(imat(ns) .eq. 0 .or. (imat(ns) .ge. 900 .and. imat(ns) .lt. 2000)) cycle if(ncorn(ns) .gt. 3) cycle if(IUSEDM(ns) .eq. 1) cycle ! renumber elements to put them in order N=NS N1=NOP(NS,1) N3=NOP(NS,3) iseq(iseqp,k)=ns IUSEDM(n)=1 go to 100 enddo go to 200 100 continue ! search for element connected to n1 or n3 do m=1,ne if(imat(ns) .eq. 0 .or. (imat(ns) .ge. 900 .and. imat(ns) .lt. 2000)) cycle ! if(imat(m) .gt. 0 .and. imat(m) .lt. 900) then if(ncorn(m) .lt. 4) then if(IUSEDM(m) .eq. 1) cycle if(nop(m,1) .eq. n3) then IUSEDM(m)=1 iseqp=iseqp+1 iseq(iseqp,k)=m ! n1=nop(m,1) n3=nop(m,3) n=m go to 100 elseif(nop(m,1) .eq. n1) then nop(m,1)=nop(m,3) nop(m,3)=n1 IUSEDM(m)=1 iseqm=iseqm-1 iseq(iseqm,k)=m n1=nop(m,1) ! n3=nop(m,3) n=m go to 100 elseif(nop(m,3) .eq. n1) then IUSEDM(m)=1 iseqm=iseqm-1 iseq(iseqm,k)=m n1=nop(m,1) ! n3=nop(m,3) n=m go to 100 elseif(nop(m,3) .eq. n3) then nop(m,3)=nop(m,1) nop(m,1)=n3 IUSEDM(m)=1 iseqp=iseqp+1 iseq(iseqp,k)=m ! n1=nop(m,1) n3=nop(m,3) n=m go to 100 endif endif ! endif enddo enddo 200 continue ! do n=990,1005 ! write(150,*) n,(iseq(n,m),m=1,5) ! enddo NETEMP=NE do k=1,10 nss=0 do ns=1,4000 if(iseq(ns,k) .eq. 0) cycle n=iseq(ns,k) N1=NOP(N,1) N2=NOP(N,2) N3=NOP(N,3) if(nss .eq. 0) then ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1)) CALL GETNOD(J1) INEW(J1) = 1 INSKP(J1) =0 IF(ISWTH .EQ. 1) THEN WD(J1)=HSET(N1,3) ELSE WD(J1)=-9999. ENDIF CALL GETNOD(J2) INEW(J2) = 1 INSKP(J2) =0 IF(ISWTH .EQ. 1) THEN WD(J2)=HSET(N1,1) ELSE WD(J2)=-9999. ENDIF ! XUSR(J1)=+WIDTHD(N1)/2.*COS(ELDIR-PI2)+XUSR(N1) ! YUSR(J1)=+WIDTHD(N1)/2.*SIN(ELDIR-PI2)+YUSR(N1) XUSR(J1)=+WIDTH(N1)/2.*COS(ELDIR-PI2)+XUSR(N1) YUSR(J1)=+WIDTH(N1)/2.*SIN(ELDIR-PI2)+YUSR(N1) CORD(J1,1)=(XUSR(J1)+XS)/TXSCAL CORD(J1,2)=(YUSR(J1)+YS)/TXSCAL IF(ISWT9 .EQ. 2) THEN WD(J1)=WD(N1) ENDIF nnn=iseq(ns+1,k) if(nnn .eq. 0) then ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1)) else n4=nop(nnn,3) ELDIR=ATAN2(YUSR(N4)-YUSR(N1),XUSR(N4)-XUSR(N1)) endif ! XUSR(J2)=+WIDTHD(N1)/2.*COS(ELDIR+PI2)+XUSR(N1) ! YUSR(J2)=+WIDTHD(N1)/2.*SIN(ELDIR+PI2)+YUSR(N1) XUSR(J2)=+WIDTH(N1)/2.*COS(ELDIR+PI2)+XUSR(N1) YUSR(J2)=+WIDTH(N1)/2.*SIN(ELDIR+PI2)+YUSR(N1) CORD(J2,1)=(XUSR(J2)+XS)/TXSCAL CORD(J2,2)=(YUSR(J2)+YS)/TXSCAL IF(ISWT9 .EQ. 2) THEN WD(J2)=WD(N1) ENDIF nss=1 else nnn=iseq(ns+1,k) if(nnn .eq. 0) then ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1)) else n4=nop(nnn,3) ELDIR=ATAN2(YUSR(N4)-YUSR(N1),XUSR(N4)-XUSR(N1)) endif endif N0=N1 ! get two node numbers and store in ntempc CALL GETNOD(J3) INEW(J3) = 1 INSKP(J3) =0 IF(ISWTH .EQ. 1) THEN WD(J3)=HSET(N3,3) ELSE WD(J3)=-9999. ENDIF CALL GETNOD(J4) INEW(J4) = 1 INSKP(J4) =0 IF(ISWTH .EQ. 1) THEN WD(J4)=HSET(N3,1) ELSE WD(J4)=-9999. ENDIF IF(J4 .GT. NP) NP=J4 nn= imat(n) if(nn .gt. 1999) then ! XUSR(J3)=+WIDTHD(N3)/2.*COS(ELDIR-PI2)+XUSR(N3) ! YUSR(J3)=+WIDTHD(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3) ! XUSR(J4)=+WIDTHD(N3)/2.*COS(ELDIR+PI2)+XUSR(N3) ! YUSR(J4)=+WIDTHD(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3) XUSR(J3)=+WIDTH(N3)/2.*COS(ELDIR-PI2)+XUSR(N3) YUSR(J3)=+WIDTH(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3) XUSR(J4)=+WIDTH(N3)/2.*COS(ELDIR+PI2)+XUSR(N3) YUSR(J4)=+WIDTH(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3) ELSEIF(KID(nn,1) .NE. 0) THEN JR2=KID(IMAT(N),2) JR1=KID(IMAT(N),3) JR4=KID(IMAT(N),4) JR3=KID(IMAT(N),5) XUSR(J1)=XUSR(JR1) YUSR(J1)=YUSR(JR1) XUSR(J2)=XUSR(JR2) YUSR(J2)=YUSR(JR2) XUSR(J3)=XUSR(JR3) YUSR(J3)=YUSR(JR3) XUSR(J4)=XUSR(JR4) YUSR(J4)=YUSR(JR4) ! nop(n-1,7)=jr3 ELSE ! XUSR(J3)=+WIDTHD(N3)/2.*COS(ELDIR-PI2)+XUSR(N3) ! YUSR(J3)=+WIDTHD(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3) ! XUSR(J4)=+WIDTHD(N3)/2.*COS(ELDIR+PI2)+XUSR(N3) ! YUSR(J4)=+WIDTHD(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3) XUSR(J3)=+WIDTH(N3)/2.*COS(ELDIR-PI2)+XUSR(N3) YUSR(J3)=+WIDTH(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3) XUSR(J4)=+WIDTH(N3)/2.*COS(ELDIR+PI2)+XUSR(N3) YUSR(J4)=+WIDTH(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3) ENDIF CORD(J3,1)=(XUSR(J3)+XS)/TXSCAL CORD(J3,2)=(YUSR(J3)+YS)/TXSCAL CORD(J4,1)=(XUSR(J4)+XS)/TXSCAL CORD(J4,2)=(YUSR(J4)+YS)/TXSCAL IF(ISWT9 .EQ. 2) THEN WD(J3)=WD(N3) WD(J4)=WD(N3) ENDIF 350 CONTINUE CALL GETELM(I3) ! RECORD IN LIST FOR FUTURE ICL=ICL+1 LIST1(ICL)=I3 LIST2(I3)=icl NCORN(I3) = 8 IESKP(I3) = 0 NOP(I3,1)=J1 NOP(I3,3)=J3 NOP(I3,5)=N3 NOP(I3,6)=N2 NOP(I3,7)=N1 IF(ISWT9 .EQ. 0) THEN IMAT(I3)=999 ELSE IMAT(I3)=IMAT(N) ENDIF CALL GETELM(I4) ! RECORD IN LIST FOR FUTURE ICL=ICL+1 LIST1(ICL)=I4 LIST2(I4)=-icl NCORN(I4) = 8 IESKP(I4) = 0 IF(I4 .GT. NETEMP) NETEMP=I4 IMAT(I4)=999 NOP(I4,1)=J4 NOP(I4,2)= 0 NOP(I4,3)=J2 NOP(I4,5)=N1 NOP(I4,6)=N2 NOP(I4,7)=N3 IF(ISWT9 .EQ. 0) THEN IMAT(I4)=999 ELSE IMAT(I4)=IMAT(N) CALL DELTEL(N) ENDIF J2=J4 J1=J3 ENDDO enddo NE=NETEMP ICLM=ICL NELCT=2 400 CONTINUE CALL FILM(1) call KCON(0) do n=1,ne if(imat(n) .eq. 2000) then nm=nop(n,4) if(necon(nm,1) .eq. n) then nat=necon(nm,2) else nat=necon(nm,1) endif if(list2(n) .gt. 0) then nm=nop(n,4) if(necon(nm,1) .eq. n) then nat=necon(nm,2) else nat=necon(nm,1) endif n1=nop(nat,7) n2=nop(nat,1) j1=nop(n,5) j2=nop(n,7) j3=nop(n,1) j4=nop(n,3) else nm=nop(n,8) if(necon(nm,1) .eq. n) then nat=necon(nm,2) else nat=necon(nm,1) endif n1=nop(nat,3) n2=nop(nat,5) j1=nop(n,1) j2=nop(n,3) j3=nop(n,5) j4=nop(n,7) endif xusr(j1)=xusr(n1) yusr(j1)=yusr(n1) cord(j1,1)=cord(n1,1) cord(j1,2)=cord(n1,2) xusr(j2)=xusr(n1) yusr(j2)=yusr(n1) cord(j2,1)=cord(n1,1) cord(j2,2)=cord(n1,2) xusr(j3)=xusr(n2) yusr(j3)=yusr(n2) cord(j3,1)=cord(n2,1) cord(j3,2)=cord(n2,2) xusr(j4)=xusr(n2) yusr(j4)=yusr(n2) cord(j4,1)=cord(n2,1) cord(j4,2)=cord(n2,2) elseif(imat(n) .eq. 2001) then if(list2(n) .gt. 0) then nm=nop(n,8) if(necon(nm,1) .eq. n) then nat=necon(nm,2) else nat=necon(nm,1) endif n1=nop(nat,5) n2=nop(nat,3) j1=nop(n,5) j2=nop(n,7) j3=nop(n,1) j4=nop(n,3) else nm=nop(n,4) if(necon(nm,1) .eq. n) then nat=necon(nm,2) else nat=necon(nm,1) endif n1=nop(nat,1) n2=nop(nat,7) j1=nop(n,1) j2=nop(n,3) j3=nop(n,5) j4=nop(n,7) endif xusr(j1)=xusr(n1) yusr(j1)=yusr(n1) cord(j1,1)=cord(n1,1) cord(j1,2)=cord(n1,2) xusr(j2)=xusr(n1) yusr(j2)=yusr(n1) cord(j2,1)=cord(n1,1) cord(j2,2)=cord(n1,2) xusr(j3)=xusr(n2) yusr(j3)=yusr(n2) cord(j3,1)=cord(n2,1) cord(j3,2)=cord(n2,2) xusr(j4)=xusr(n2) yusr(j4)=yusr(n2) cord(j4,1)=cord(n2,1) cord(j4,2)=cord(n2,2) endif enddo 450 CALL DELETM(0) IF(NELC .LE. NELCT) THEN NMESS=47 CALL GETINT(NNEL) IF(NNEL .EQ. 2) GO TO 470 ! Loop on newly created elements only DO K=1,ICL,2 ! work in pairs N1=LIST1(K) N2=LIST1(K+1) NMT=IMAT(N1) ! temporarily get corner limits I1,I2,I3,I4 I1=NOP(N1,1) I2=NOP(N2,3) I3=NOP(N1,3) I4=NOP(N2,1) ! Delete nodes in middle JJ=NOP(N1,7) JK=NOP(N1,5) CALL DELETN(JJ) IF(K .EQ. ICL-1) THEN CALL DELETN(JK) ENDIF ! CALL DELTEL(N1) ! CALL DELTEL(N2) ! Get x and y increments DX1=(XUSR(I2)-XUSR(I1))/NNEL DY1=(YUSR(I2)-YUSR(I1))/NNEL DX2=(XUSR(I4)-XUSR(I3))/NNEL DY2=(YUSR(I4)-YUSR(I3))/NNEL ! loop on new elements across section J1OLD(1)=I1 J2OLD(1)=I3 IF(K .GT. 1) THEN DO L=1,NNEL+1 J1OLD(L+1)=J2OLD(L+1) ENDDO ENDIF ! loop to creat nodes across section DO L=1,NNEL ! Create new nodes for first in sequence IF(K .EQ. 1) THEN IF(L .LT. NNEL) THEN CALL GETNOD(JNEW) J1OLD(L+1)=JNEW NP=MAX(NP,J1OLD(L+1)) XUSR(J1OLD(L+1))=XUSR(J1OLD(L))+DX1 YUSR(J1OLD(L+1))=YUSR(J1OLD(L))+DY1 CORD(J1OLD(L+1),1)=(XUSR(J1OLD(L+1))+XS)/TXSCAL CORD(J1OLD(L+1),2)=(YUSR(J1OLD(L+1))+YS)/TXSCAL INEW(J1OLD(L+1))=1 INSKP(J1OLD(L+1)) = 0 WD(J1OLD(L+1))=-9999. WIDTH(J1OLD(L+1))=0. SS1(J1OLD(L+1))=0. SS2(J1OLD(L+1))=0. WIDS(J1OLD(L+1))=0. WIDBS(J1OLD(L+1))=0. SSO(J1OLD(L+1))=0. ELSE J1OLD(L+1)=I2 ENDIF ENDIF ! save forward nodes as list IF(L .LT. NNEL) THEN CALL GETNOD(JNEW) J2OLD(L+1)=JNEW NP=MAX(NP,J2OLD(L+1)) XUSR(J2OLD(l+1))=XUSR(J2OLD(L))+DX2 YUSR(J2OLD(L+1))=YUSR(J2OLD(L))+DY2 CORD(J2OLD(L+1),1)=(XUSR(J2OLD(L+1))+XS)/TXSCAL CORD(J2OLD(L+1),2)=(YUSR(J2OLD(L+1))+YS)/TXSCAL INEW(J2OLD(L+1))=1 INSKP(J2OLD(L+1)) = 0 WD(J2OLD(L+1))=-9999. WIDTH(J2OLD(L+1))=0. SS1(J2OLD(L+1))=0. SS2(J2OLD(L+1))=0. WIDS(J2OLD(L+1))=0. WIDBS(J2OLD(L+1))=0. SSO(J2OLD(L+1))=0. ELSE J2OLD(L+1)=I4 ENDIF ! Connect elements from list CALL GETELM(NEA) NE=MAX(NE,NEA) NOP(NEA,1)=J1OLD(L) NOP(NEA,3)=J2OLD(L) NOP(NEA,5)=J2OLD(L+1) NOP(NEA,7)=J1OLD(L+1) NOP(NEA,2)=0 NOP(NEA,4)=0 NOP(NEA,6)=0 NOP(NEA,8)=0 IMAT(NEA)=NMT NCORN(NEA) = 8 IESKP(NEA) = 0 ENDDO ENDDO 470 CONTINUE do n=1,ne if(imat(n) .gt. 1000) then CALL DELTEL(n) endif enddo RETURN ENDIF DO I=1,ICLM,2 NEL=LIST1(I) IF(IMAT(NEL) .EQ. 0) CYCLE IF(I .GT. 1) THEN J3=J4 ELSE CALL GETNOD(J3) XUSR(J3)=(XUSR(NOP(NEL,7))+XUSR(NOP(NEL,1)))/2. YUSR(J3)=(YUSR(NOP(NEL,7))+YUSR(NOP(NEL,1)))/2. CORD(J3,1)=(XUSR(J3)+XS)/TXSCAL CORD(J3,2)=(YUSR(J3)+YS)/TXSCAL WD(J3)=(WD(NOP(NEL,1))+WD(NOP(NEL,7)))/2. INEW(J3) = 1 INSKP(J3) =0 IF(J3 .GT. NP) NP=J3 ENDIF CALL GETNOD(J4) XUSR(J4)=(XUSR(NOP(NEL,3))+XUSR(NOP(NEL,5)))/2. YUSR(J4)=(YUSR(NOP(NEL,3))+YUSR(NOP(NEL,5)))/2. CORD(J4,1)=(XUSR(J4)+XS)/TXSCAL CORD(J4,2)=(YUSR(J4)+YS)/TXSCAL WD(J4)=(WD(NOP(NEL,3))+WD(NOP(NEL,5)))/2. INEW(J4) = 1 INSKP(J4) =0 IF(J4 .GT. NP) NP=J4 CALL GETELM(I3) ! RECORD IN LIST FOR FUTURE ICL=ICL+1 LIST1(ICL)=I3 NCORN(I3) = 8 IESKP(I3) = 0 IF(I3 .GT. NETEMP) NETEMP=I3 NOP(I3,5)=J4 NOP(I3,7)=J3 NOP(I3,1)=NOP(NEL,1) NOP(I3,3)=NOP(NEL,3) NOP(NEL,1)=J3 NOP(NEL,3)=J4 IMAT(I3)=IMAT(NEL) NEL=LIST1(I+1) IF(IMAT(NEL) .EQ. 0) CYCLE IF(I .GT. 1) THEN J3A=J4A ELSE CALL GETNOD(J3A) XUSR(J3A)=(XUSR(NOP(NEL,3))+XUSR(NOP(NEL,5)))/2. YUSR(J3A)=(YUSR(NOP(NEL,3))+YUSR(NOP(NEL,5)))/2. CORD(J3A,1)=(XUSR(J3A)+XS)/TXSCAL CORD(J3A,2)=(YUSR(J3A)+YS)/TXSCAL WD(J3A)=(WD(NOP(NEL,3))+WD(NOP(NEL,5)))/2. INEW(J3A) = 1 INSKP(J3A) =0 IF(J3A .GT. NP) NP=J3A ENDIF CALL GETNOD(J4A) XUSR(J4A)=(XUSR(NOP(NEL,1))+XUSR(NOP(NEL,7)))/2. YUSR(J4A)=(YUSR(NOP(NEL,1))+YUSR(NOP(NEL,7)))/2. CORD(J4A,1)=(XUSR(J4A)+XS)/TXSCAL CORD(J4A,2)=(YUSR(J4A)+YS)/TXSCAL WD(J4A)=(WD(NOP(NEL,1))+WD(NOP(NEL,7)))/2. INEW(J4A) = 1 INSKP(J4A) =0 IF(J4A .GT. NP) NP=J4A CALL GETELM(I3) ! RECORD IN LIST FOR FUTURE ICL=ICL+1 LIST1(ICL)=I3 NCORN(I3) = 8 IESKP(I3) = 0 IF(I3 .GT. NETEMP) NETEMP=I3 NOP(I3,1)=J4A NOP(I3,3)=J3A NOP(I3,5)=NOP(NEL,5) NOP(I3,7)=NOP(NEL,7) NOP(NEL,5)=J3A NOP(NEL,7)=J4A IMAT(I3)=IMAT(NEL) ENDDO NELCT=NELCT*2 GO TO 450 ! RETURN END