1! 2! CalculiX - A 3-dimensional finite element program 3! Copyright (C) 1998-2021 Guido Dhondt 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU General Public License as 7! published by the Free Software Foundation(version 2); 8! 9! 10! This program is distributed in the hope that it will be useful, 11! but WITHOUT ANY WARRANTY; without even the implied warranty of 12! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13! GNU General Public License for more details. 14! 15! You should have received a copy of the GNU General Public License 16! along with this program; if not, write to the Free Software 17! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 18! 19 subroutine cfluxs(inpc,textpart,set,istartset,iendset, 20 & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, 21 & amname,nam,ntrans,trab,inotr,co,ikforc,ilforc,nk, 22 & cflux_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_, 23 & namtot_,namta,amta,iaxial,ipoinpc,idefforc,ipompc,nodempc, 24 & nmpc,ikmpc,ilmpc,labmpc,iamplitudedefault,namtot,ier) 25! 26! reading the input deck: *CFLUX 27! 28 implicit none 29! 30 logical cflux_flag,user,add 31! 32 character*1 inpc(*) 33 character*20 labmpc(*) 34 character*80 amplitude,amname(*) 35 character*81 set(*),noset 36 character*132 textpart(16) 37! 38 integer istartset(*),iendset(*),ialset(*),nodeforc(2,*), 39 & nset,nforc,nforc_,istep,istat,n,i,j,k,l,iforcdir,key, 40 & iamforc(*),nam,iamplitude,ntrans,inotr(2,*),ipos,ikforc(*), 41 & ilforc(*),nk,iline,ipol,inl,ipoinp(2,*),inp(3,*),nam_,namtot, 42 & namtot_,namta(3,*),idelay,ndirforc(*),isector,iaxial, 43 & ipoinpc(0:*),idefforc(*),ipompc(*),id, 44 & nodempc(3,*),nmpc,ikmpc(*),ilmpc(*),iamplitudedefault,ier 45! 46 real*8 xforc(*),forcval,co(3,*),trab(7,*),amta(2,*) 47! 48 iamplitude=iamplitudedefault 49 idelay=0 50 user=.false. 51 add=.false. 52 isector=0 53! 54 if(istep.lt.1) then 55 write(*,*) '*ERROR reading *CFLUX: *CFLUX should only be used' 56 write(*,*) ' within a STEP' 57 ier=1 58 return 59 endif 60! 61 do i=2,n 62 if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.cflux_flag)) then 63 do j=1,nforc 64 if(ndirforc(j).eq.0) xforc(j)=0.d0 65 enddo 66 elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then 67 read(textpart(i)(11:90),'(a80)') amplitude 68 do j=nam,1,-1 69 if(amname(j).eq.amplitude) then 70 iamplitude=j 71 exit 72 endif 73 enddo 74 if(j.eq.0) then 75 write(*,*)'*ERROR reading *CFLUX: nonexistent amplitude' 76 write(*,*) ' ' 77 call inputerror(inpc,ipoinpc,iline, 78 & "*CFLUX%",ier) 79 return 80 endif 81 iamplitude=j 82 elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN 83 if(idelay.ne.0) then 84 write(*,*) 85 & '*ERROR reading *CFLUX: the parameter TIME DELAY' 86 write(*,*) ' is used twice in the same keyword' 87 write(*,*) ' ' 88 call inputerror(inpc,ipoinpc,iline, 89 & "*CFLUX%",ier) 90 return 91 else 92 idelay=1 93 endif 94 nam=nam+1 95 if(nam.gt.nam_) then 96 write(*,*) '*ERROR reading *CFLUX: increase nam_' 97 ier=1 98 return 99 endif 100 amname(nam)=' 101 & ' 102 if(iamplitude.eq.0) then 103 write(*,*) '*ERROR reading *CFLUX: time delay must be' 104 write(*,*) ' preceded by the amplitude parameter' 105 ier=1 106 return 107 endif 108 namta(3,nam)=sign(iamplitude,namta(3,iamplitude)) 109 iamplitude=nam 110c if(nam.eq.1) then 111c namtot=0 112c else 113c namtot=namta(2,nam-1) 114c endif 115 namtot=namtot+1 116 if(namtot.gt.namtot_) then 117 write(*,*) '*ERROR cfluxes: increase namtot_' 118 ier=1 119 return 120 endif 121 namta(1,nam)=namtot 122 namta(2,nam)=namtot 123c call reorderampl(amname,namta,nam) 124 read(textpart(i)(11:30),'(f20.0)',iostat=istat) 125 & amta(1,namtot) 126 if(istat.gt.0) then 127 call inputerror(inpc,ipoinpc,iline, 128 & "*CFLUX%",ier) 129 return 130 endif 131 elseif(textpart(i)(1:4).eq.'USER') then 132 user=.true. 133 elseif(textpart(i)(1:3).eq.'ADD') then 134 add=.true. 135 else 136 write(*,*) 137 & '*WARNING reading *CFLUX: parameter not recognized:' 138 write(*,*) ' ', 139 & textpart(i)(1:index(textpart(i),' ')-1) 140 call inputwarning(inpc,ipoinpc,iline, 141 &"*CFLUX%") 142 endif 143 enddo 144! 145 if(user.and.(iamplitude.ne.0)) then 146 write(*,*) '*WARNING: no amplitude definition is allowed' 147 write(*,*) ' for heat fluxes defined by a' 148 write(*,*) ' user routine' 149 iamplitude=0 150 endif 151! 152 do 153 call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, 154 & ipoinp,inp,ipoinpc) 155 if((istat.lt.0).or.(key.eq.1)) return 156! 157 read(textpart(2)(1:10),'(i10)',iostat=istat) iforcdir 158 if(istat.gt.0) then 159 call inputerror(inpc,ipoinpc,iline, 160 & "*CFLUX%",ier) 161 return 162 endif 163 if((iforcdir.ne.0).and.(iforcdir.ne.11)) then 164 write(*,*) '*ERROR reading *CFLUX: nonexistent degree of ' 165 write(*,*) ' freedom. ' 166 call inputerror(inpc,ipoinpc,iline, 167 & "*CFLUX%",ier) 168 return 169 endif 170 iforcdir=0 171! 172 if(textpart(3)(1:1).eq.' ') then 173 forcval=0.d0 174 else 175 read(textpart(3)(1:20),'(f20.0)',iostat=istat) forcval 176 if(istat.gt.0) then 177 call inputerror(inpc,ipoinpc,iline, 178 & "*CFLUX%",ier) 179 return 180 endif 181 if(iaxial.eq.180) forcval=forcval/iaxial 182 endif 183! 184! dummy flux consisting of the first primes 185! 186 if(user) forcval=1.2357111317d0 187! 188 read(textpart(1)(1:10),'(i10)',iostat=istat) l 189 if(istat.eq.0) then 190 if(l.gt.nk) then 191 write(*,*) '*ERROR reading *CFLUX: node ',l 192 write(*,*) ' is not defined' 193 ier=1 194 return 195 endif 196 call forcadd(l,iforcdir,forcval, 197 & nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, 198 & iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc, 199 & isector,add,user,idefforc,ipompc,nodempc, 200 & nmpc,ikmpc,ilmpc,labmpc) 201 else 202 read(textpart(1)(1:80),'(a80)',iostat=istat) noset 203 noset(81:81)=' ' 204 ipos=index(noset,' ') 205 noset(ipos:ipos)='N' 206c do i=1,nset 207c if(set(i).eq.noset) exit 208c enddo 209 call cident81(set,noset,nset,id) 210 i=nset+1 211 if(id.gt.0) then 212 if(noset.eq.set(id)) then 213 i=id 214 endif 215 endif 216 if(i.gt.nset) then 217 noset(ipos:ipos)=' ' 218 write(*,*) '*ERROR reading *CFLUX: node set ',noset 219 write(*,*) ' has not yet been defined. ' 220 call inputerror(inpc,ipoinpc,iline, 221 & "*CFLUX%",ier) 222 return 223 endif 224 do j=istartset(i),iendset(i) 225 if(ialset(j).gt.0) then 226 call forcadd(ialset(j),iforcdir,forcval, 227 & nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, 228 & iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc, 229 & isector,add,user,idefforc,ipompc,nodempc, 230 & nmpc,ikmpc,ilmpc,labmpc) 231 else 232 k=ialset(j-2) 233 do 234 k=k-ialset(j) 235 if(k.ge.ialset(j-1)) exit 236 call forcadd(k,iforcdir,forcval, 237 & nodeforc,ndirforc,xforc,nforc,nforc_, 238 & iamforc,iamplitude,nam,ntrans,trab,inotr,co, 239 & ikforc,ilforc,isector,add,user,idefforc, 240 & ipompc,nodempc,nmpc,ikmpc,ilmpc,labmpc) 241 enddo 242 endif 243 enddo 244 endif 245 enddo 246! 247 return 248 end 249 250