!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2005 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!     
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of 
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine radflowload(itg,ieg,ntg,ntr,ntm,
     &  ac,bc,nload,sideload,nelemload,xloadact,lakon,ipiv,ntmat_,vold,
     &  shcon,nshcon,ipkon,kon,co,pmid,e1,e2,e3,iptri,
     &  kontri,ntri,nloadtr,tarea,tenv,physcon,erad,f,
     &  dist,idist,area,nflow,ikboun,xbounact,nboun,ithermal,iinc,iit,
     &  cs,mcs,inocs,ntrit,nk,fenv,istep,dtime,ttime,time,ilboun,
     &  ikforc,ilforc,xforcact,nforc,cam,ielmat)
!
      implicit none
!
      logical covered(160,160)
!
      character*4 label(10)
      character*8 lakonl,lakon(*)
      character*20 sideload(*)
!
      integer itg(*),ieg(*),ntg,ntr,nflow,nload,ielmat(*),
     &  nelemload(2,*),nope,nopes,mint2d,nrhs,ipiv(*),info,i,j,k,l,
     &  node,imat,ntmat_,id1,id2,id,ntm,ifaceq(8,6),ifacet(6,4),
     &  ifacew(8,5),node1,node2,nshcon(*),nelem,ig,index,konl(20),
     &  ipkon(*),kon(*),ncovered,kontri(3,*),iptri(*),nloadtr(*),
     &  i1,j1,istart,iend,jstart,jend,imin,imid,imax,mcs,inocs(*),
     &  k1,kflag,idist(*),ndist,i2,i3,ng,idi,idj,ntri,ikboun(*),
     &  nboun,idof,ithermal,iinc,iit,ix,iy,ntrit,jj,is,m,jmod,nkt,
     &  icntrl,imag,nk,ienv,istep,jltyp,nfield,ilboun(*),ikforc(*),
     &  ilforc(*),nforc,nodem
!
      real*8 ac(ntm,*),bc(ntm,1),xloadact(2,*),cp,h(2),
     &  xl2(0:3,8),coords(3),dxsj2,temp,xi,et,weight,xsj2(3),
     &  gastemp,vold(0:3,*),shcon(0:1,ntmat_,*),co(3,*),shp2(4,8),
     &  pmid(3,*),e3(4,*),e1(3,*),e2(3,*),p1(3),p2(3),p3(3),
     &  areamean,tarea(*),tenv(*),x,y,cs(17,*),
     &  erad(*),q,fenv(*),e,ec,physcon(3),yymin,yymax,xxmin,
     &  xxmid,xxmax,dummy,a(3,3),b(3,3),c(3,3),
     &  xx(3),yy(3),ftij,f(ntr,*),dint,cospsij,dir(3),
     &  dirloc(3),dist(*),area(*),dd,p21(3),p32(3),xbounact(*),summass,
     &  totarea,fn,stn,qfn,een,t(3),ftot,sidemean,tvar(2),field,
     &  dtime,ttime,time,xforcact(*),areaj,cam,xflow
!
      real*8 gauss2d1(2,1),gauss2d2(2,4),gauss2d3(2,9),gauss2d4(2,1),
     &  gauss2d5(2,3),gauss3d1(3,1),gauss3d2(3,8),gauss3d3(3,27),
     &  gauss3d4(3,1),gauss3d5(3,4),gauss3d6(3,15),gauss3d7(3,2),
     &  gauss3d8(3,9),gauss3d9(3,18),weight2d1(1),weight2d2(4),
     &  weight2d3(9),weight2d4(1),weight2d5(3),weight3d1(1),
     &  weight3d2(8),weight3d3(27),weight3d4(1),weight3d5(4),
     &  weight3d6(15),weight3d7(2),weight3d8(9),weight3d9(18)
!
      include "gauss.f"
!
      data ifaceq /4,3,2,1,11,10,9,12,
     &            5,6,7,8,13,14,15,16,
     &            1,2,6,5,9,18,13,17,
     &            2,3,7,6,10,19,14,18,
     &            3,4,8,7,11,20,15,19,
     &            4,1,5,8,12,17,16,20/
      data ifacet /1,3,2,7,6,5,
     &             1,2,4,5,9,8,
     &             2,3,4,6,10,9,
     &             1,4,3,8,10,7/
      data ifacew /1,3,2,9,8,7,0,0,
     &             4,5,6,10,11,12,0,0,
     &             1,2,5,4,7,14,10,13,
     &             2,3,6,5,8,15,11,14,
     &             4,6,3,1,12,15,9,13/
!
      save ienv
!
      cam=0.d0
!
      tvar(1)=time
      tvar(2)=ttime+dtime
!
!     solving for the gas temperatures in forced convection
!
      ftot=0.d0
      if(ntg.gt.0) then
!
!        initialization of ac and bc
!
         do i=1,ntg
            do j=1,ntg
               ac(i,j)=0.d0
            enddo
            bc(i,1)=0.d0
         enddo
!
!        mass flow
!
         do i=1,nflow
            nelem=ieg(i)
            index=ipkon(nelem)
            node1=kon(index+1)
            nodem=kon(index+2)
            node2=kon(index+3)
            idof=7*(nodem-1)+1
            call nident(ikboun,idof,nboun,id)
            if(id.le.0) then
               cycle
            elseif(ikboun(id).ne.idof) then
               cycle
            endif
            xflow=xbounact(ilboun(id))
            call nident(itg,node1,ntg,id1)
            call nident(itg,node2,ntg,id2)
            gastemp=(vold(0,node1)+vold(0,node2))/2.d0
            imat=ielmat(nelem)
            call matdata_tg(imat,ntmat_,gastemp,shcon,nshcon,cp)
            if(xflow.ge.0.d0) then
               ac(id2,id2)=ac(id2,id2)+cp*xflow
               ac(id2,id1)=ac(id2,id1)-cp*xflow
            else
               ac(id1,id1)=ac(id1,id1)-cp*xflow
               ac(id1,id2)=ac(id1,id2)+cp*xflow
            endif
         enddo
!
c         do i=1,nflow
c            node1=nodeflow(1,i)
c            node2=nodeflow(2,i)
c!
c!           check whether the nodes were used in the flux
c!           definitions
c!
c            if(xflowact(i).ge.0.d0) then
c               call nident(itg,node1,ntg,id1)
c               if(id1.le.0) then
c                  cycle
c               elseif(itg(id1).ne.node1) then
c                  cycle
c               endif
c               ac(id1,id1)=ac(id1,id1)+xflowact(i)
c               call nident(itg,node2,ntg,id2)
c               if(id2.le.0) then
c                  cycle
c               elseif(itg(id2).ne.node2) then
c                  cycle
c               endif
c               ac(id2,id1)=ac(id2,id1)-xflowact(i)
c            else
c               call nident(itg,node2,ntg,id2)
c               if(id2.le.0) then
c                  cycle
c               elseif(itg(id2).ne.node2) then
c                  cycle
c               endif
c               ac(id2,id2)=ac(id2,id2)-xflowact(i)
c               call nident(itg,node1,ntg,id1)
c               if(id1.le.0) then
c                  cycle
c               elseif(itg(id1).ne.node1) then
c                  cycle
c               endif
c               ac(id1,id2)=ac(id1,id2)+xflowact(i)
c            endif
c         enddo
c!
c!        check whether mass is conserved in each gas temperature node
c!        (only for nodes for which the temperature is not fixed)
c!
c         do i=1,ntg
c!
c            node=itg(i)
c            idof=7*(node-1)
c            call nident(ikboun,idof,nboun,id)
c            if(id.gt.0) then
c               if(ikboun(id).eq.idof) cycle
c            endif
c!
c            summass=0.d0
c            do j=1,ntg
c               summass=summass+ac(i,j)
c            enddo
cc            write(*,*) 'summass ',summass,ac(i,i)
c!
c!            last point in the gas temperature chain
c!
c            if(ac(i,i).lt.1.d-20) then
c               ac(i,i)=-summass
c               summass=0.d0
c            endif
c!
c            if((dabs(summass).gt.1.d-20).and.
cc     &         ((summass-ac(i,i)).gt.1.d-20).and.
c     &         ((dabs(summass).gt.1.d-3*ac(i,i)).or.
c     &          (dabs(summass).gt.1.d-3*(summass-ac(i,i))))) then
c               write(*,*) '*WARNING in radflowload: mass is not conserve
c     &d for node ',itg(i)
c            endif
c         enddo
c!
c!        specific heat of the gas
c!               
c         do i=1,ntg
c            node=itg(i)
c            gastemp=vold(0,node)
c            imat=matg(i)
c            call matdata_tg(imat,ntmat_,gastemp,shcon,nshcon,cp)
c            do j=1,ntg
c               ac(i,j)=ac(i,j)*cp
c            enddo
c         enddo
!
!        convection with the walls
!
         do i=1,nload
            if(sideload(i)(3:4).eq.'FC') then
               nelem=nelemload(1,i)
               lakonl=lakon(nelem)
               node=nelemload(2,i)
               call nident(itg,node,ntg,id)
!
!              calculate the area
!
               read(sideload(i)(2:2),'(i1)') ig
!
!              number of nodes and integration points in the face
!
               if(lakonl(4:4).eq.'2') then
                  nope=20
                  nopes=8
               elseif(lakonl(4:4).eq.'8') then
                  nope=8
                  nopes=4
               elseif(lakonl(4:5).eq.'10') then
                  nope=10
                  nopes=6
               elseif(lakonl(4:4).eq.'4') then
                  nope=4
                  nopes=3
               elseif(lakonl(4:5).eq.'15') then
                  nope=15
               else
                  nope=6
               endif
!
               if(lakonl(4:5).eq.'8R') then
                  mint2d=1
               elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R'))
     &            then
                  mint2d=4
               elseif(lakonl(4:4).eq.'2') then
                  mint2d=9
               elseif(lakonl(4:5).eq.'10') then
                  mint2d=3
               elseif(lakonl(4:4).eq.'4') then
                  mint2d=1
               endif
!
               if(lakonl(4:4).eq.'6') then
                  mint2d=1
                  if(ig.le.2) then
                     nopes=3
                  else
                     nopes=4
                  endif
               endif
               if(lakonl(4:5).eq.'15') then
                  if(ig.le.2) then
                     mint2d=3
                     nopes=6
                  else
                     mint2d=4
                     nopes=8
                  endif
               endif
!
!              connectivity of the element
!
               index=ipkon(nelem)
               if(index.lt.0) then
                  write(*,*) '*ERROR in radflowload: element ',nelem
                  write(*,*) '       is not defined'
                  stop
               endif
               do k=1,nope
                  konl(k)=kon(index+k)
               enddo
!
!              coordinates of the nodes belonging to the face
!
               if((nope.eq.20).or.(nope.eq.8)) then
                  do k=1,nopes
                     xl2(0,k)=vold(0,konl(ifaceq(k,ig)))
                     do j=1,3
                        xl2(j,k)=co(j,konl(ifaceq(k,ig)))+
     &                       vold(j,konl(ifaceq(k,ig)))
                     enddo
                  enddo
               elseif((nope.eq.10).or.(nope.eq.4)) then
                  do k=1,nopes
                     xl2(0,k)=vold(0,konl(ifacet(k,ig)))
                     do j=1,3
                        xl2(j,k)=co(j,konl(ifacet(k,ig)))+
     &                       vold(j,konl(ifacet(k,ig)))
                     enddo
                  enddo
               else
                  do k=1,nopes
                     xl2(0,k)=vold(0,konl(ifacew(k,ig)))
                     do j=1,3
                        xl2(j,k)=co(j,konl(ifacew(k,ig)))+
     &                       vold(j,konl(ifacew(k,ig)))
                     enddo
                  enddo
               endif
!
!              integration to obtain the area and the mean
!              temperature
!
               do l=1,mint2d
                  if((lakonl(4:5).eq.'8R').or.
     &                 ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then
                     xi=gauss2d1(1,l)
                     et=gauss2d1(2,l)
                     weight=weight2d1(l)
                  elseif((lakonl(4:4).eq.'8').or.
     &                    (lakonl(4:6).eq.'20R').or.
     &                    ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then
                     xi=gauss2d2(1,l)
                     et=gauss2d2(2,l)
                     weight=weight2d2(l)
                  elseif(lakonl(4:4).eq.'2') then
                     xi=gauss2d3(1,l)
                     et=gauss2d3(2,l)
                     weight=weight2d3(l)
                  elseif((lakonl(4:5).eq.'10').or.
     &                    ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then
                     xi=gauss2d5(1,l)
                     et=gauss2d5(2,l)
                     weight=weight2d5(l)
                  elseif((lakonl(4:4).eq.'4').or.
     &                    ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then
                     xi=gauss2d4(1,l)
                     et=gauss2d4(2,l)
                     weight=weight2d4(l)
                  endif
!
                  if(nopes.eq.8) then
                     call shape8q(xi,et,xl2,xsj2,shp2)
                  elseif(nopes.eq.4) then
                     call shape4q(xi,et,xl2,xsj2,shp2)
                  elseif(nopes.eq.6) then
                     call shape6tri(xi,et,xl2,xsj2,shp2)
                  else
                     call shape3tri(xi,et,xl2,xsj2,shp2)
                  endif
!
                  dxsj2=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+
     &                 xsj2(3)*xsj2(3))
                  areaj=dxsj2*weight
!
                  temp=0.d0
                  do k=1,3
                     coords(k)=0.d0
                  enddo
                  do j=1,nopes
                     temp=temp+xl2(0,j)*shp2(4,j)
                     do k=1,3
                        coords(k)=coords(k)+xl2(k,j)*shp2(4,j)
                     enddo
                  enddo
!
                  if(sideload(i)(5:6).ne.'NU') then
                     h(1)=xloadact(1,i)
                  else
                     read(sideload(i)(2:2),'(i1)') jltyp
                     jltyp=jltyp+10
                     call film(h,vold(0,node),temp,istep,
     &                    iinc,tvar,nelem,l,coords,jltyp,field,nfield,
     &                    sideload(i),node,areaj,vold)
                  endif
!
                  ac(id,id)=ac(id,id)+h(1)*dxsj2*weight
                  bc(id,1)=bc(id,1)+temp*h(1)*dxsj2*weight
               enddo
            endif
         enddo
!
!        check for boundary conditions
!
         do i=1,ntg
            node=itg(i)
            idof=7*(node-1)
!
!           prescribed temperature
!
            call nident(ikboun,idof,nboun,id)
            if(id.gt.0) then
               if(ikboun(id).eq.idof) then
                  do j=1,ntg
                     if(j.eq.i) then
                        ac(j,j)=1.d0
                     else
                        ac(i,j)=0.d0
                     endif
                  enddo
                  bc(i,1)=xbounact(ilboun(id))
                  cycle
               endif
            endif
!
!           prescribed heat generation        
!
            call nident(ikforc,idof,nforc,id)
            if(id.gt.0) then
               if(ikforc(id).eq.idof) then
                  bc(i,1)=bc(i,1)+xforcact(ilforc(id))
                  cycle
               endif
            endif
         enddo
!
!        solving the system
!
         nrhs=1
         call dgesv(ntg,nrhs,ac,ntm,ipiv,bc,ntm,info)
         if(info.ne.0) then
            write(*,*) '*ERROR in radflowload: singular matrix'
            stop
         endif
!
         do i=1,ntg
            node=itg(i)
            cam=max(cam,dabs(vold(0,node)-bc(i,1)))
            vold(0,node)=bc(i,1)
         enddo
!
!        updating the film boundary conditions
!
         do i=1,nload
            if(sideload(i)(3:4).eq.'FC') then
               node=nelemload(2,i)
               call nident(itg,node,ntg,id)
               xloadact(2,i)=bc(id,1)
            endif
         enddo
!
      endif
!
!     cavity radiation
!            
      if(ntr.gt.0) then
!
!        the default sink temperature is updated at the start of each
!        increment
!
         if(iit.le.0) then
            ienv=1
            do i=1,ntr
               node=nelemload(2,nloadtr(i))
               if(node.eq.0) then
                  tenv(i)=xloadact(2,nloadtr(i))-physcon(1)
               else
                  tenv(i)=vold(0,node)-physcon(1)
               endif
               if(tenv(i).lt.0.d0) then
                  ienv=0
                  exit
               endif
            enddo
         endif
!
!        for pure thermal steps the viewfactors have to be
!        calculated only once, for thermo-mechanical steps
!        (ithermal=3) they have to be recalculated in each iteration
!
         if((ithermal.eq.3).or.(iit.eq.-1)) then
!
         write(*,*) 'Calculating the viewfactors'
         write(*,*)
!
         ng=160
         dint=2.d0/ng
!
!        updating the displacements for cyclic symmetric structures
!
         if(mcs.gt.0) then
            nkt=0
            do i=1,mcs
               if(int(cs(1,i)).gt.nkt) nkt=int(cs(1,i))
            enddo
            nkt=nk*nkt
            do i=1,10
               label(i)='    '
            enddo
            label(1)(1:1)='U'
            imag=0
            icntrl=2
            call rectcyl(co,vold,fn,stn,qfn,een,cs,nk,icntrl,t,
     &            label,imag)
            do jj=0,mcs-1
               is=cs(1,jj+1)
               do i=1,is-1
                  do l=1,nk
                     if(inocs(l).ne.jj) cycle
                     do m=1,3
                        vold(m,l+nk*i)=vold(m,l)
                     enddo
                  enddo
               enddo
            enddo
            icntrl=-2
            call rectcyl(co,vold,fn,stn,qfn,een,cs,nkt,icntrl,t,
     &            label,imag)
         endif
!
!        calculating the momentaneous center of the triangles,
!        area of the triangles and normal to the triangles
!
         sidemean=0.d0
         do i=1,ntrit
            i1=kontri(1,i)
            if(i1.eq.0) cycle
            i2=kontri(2,i)
            i3=kontri(3,i)
            do j=1,3
               p1(j)=co(j,i1)+vold(j,i1)
               p2(j)=co(j,i2)+vold(j,i2)
               p3(j)=co(j,i3)+vold(j,i3)
               pmid(j,i)=(p1(j)+p2(j)+p3(j))/3.d0
               p21(j)=p2(j)-p1(j)
               p32(j)=p3(j)-p2(j)
            enddo
!
!           normal to the triangle
!
            e3(1,i)=p21(2)*p32(3)-p32(2)*p21(3)
            e3(2,i)=p21(3)*p32(1)-p32(3)*p21(1)
            e3(3,i)=p21(1)*p32(2)-p32(1)*p21(2)
!
            dd=dsqrt(e3(1,i)*e3(1,i)+e3(2,i)*e3(2,i)+
     &               e3(3,i)*e3(3,i))
!
            do j=1,3
               e3(j,i)=e3(j,i)/dd
            enddo
!
!           area of the triangle
!
            area(i)=dd/2.d0
!
!           unit vector parallel to side 1-2
!            
            dd=dsqrt(p21(1)*p21(1)+p21(2)*p21(2)+p21(3)*p21(3))
            sidemean=sidemean+dd
            do j=1,3
               e1(j,i)=p21(j)/dd
            enddo
!
!           unit vector orthogonal to e1 and e3
!
            e2(1,i)=e3(2,i)*e1(3,i)-e3(3,i)*e1(2,i)
            e2(2,i)=e3(3,i)*e1(1,i)-e3(1,i)*e1(3,i)
            e2(3,i)=e3(1,i)*e1(2,i)-e3(2,i)*e1(1,i)
!
!           the fourth component in e3 is the constant term in the
!           equation of the triangle plane in the form
!           e3(1)*x+e3(2)*y+e3(3)*z+e3(4)=0
!
            e3(4,i)=-(e3(1,i)*p1(1)+e3(2,i)*p1(2)
     &                 +e3(3,i)*p1(3))
c            write(*,*) i,(e3(j,i),j=1,4)
         enddo
         sidemean=sidemean/ntrit
!
!        determine the geometrical factors
!
!        initialization of the fields
!
         do i=1,ntr
            do j=1,ntr
               f(i,j)=0.d0
            enddo
         enddo
!
         do i=1,ntri
!
!           checking which triangles face triangle i
!
            ndist=0
            do j=1,ntrit
               if(kontri(1,j).eq.0)cycle
               if(pmid(1,j)*e3(1,i)+pmid(2,j)*e3(2,i)+
     &            pmid(3,j)*e3(3,i)+e3(4,i).le.sidemean/80.d0) cycle
               if(pmid(1,i)*e3(1,j)+pmid(2,i)*e3(2,j)+
     &            pmid(3,i)*e3(3,j)+e3(4,j).le.sidemean/80.d0) cycle
c               if(pmid(1,j)*e3(1,i)+pmid(2,j)*e3(2,i)+
c     &            pmid(3,j)*e3(3,i)+e3(4,i).le.1.d-4) cycle
c               if(pmid(1,i)*e3(1,j)+pmid(2,i)*e3(2,j)+
c     &            pmid(3,i)*e3(3,j)+e3(4,j).le.1.d-4) cycle
               ndist=ndist+1
               dist(ndist)=dsqrt((pmid(1,j)-pmid(1,i))**2+
     &                     (pmid(2,j)-pmid(2,i))**2+
     &                     (pmid(3,j)-pmid(3,i))**2)
               idist(ndist)=j
            enddo
            if(ndist.eq.0) cycle
!
!           ordering the triangles
!
            kflag=2
            call dsort(dist,idist,ndist,kflag)
!
!           initializing the coverage matrix
!
            ncovered=0
            do i1=1,ng
               x=((i1-0.5d0)*dint-1.d0)**2
               do j1=1,ng
                  y=((j1-0.5d0)*dint-1.d0)**2
                  if(x+y.gt.1.d0) then
                     covered(i1,j1)=.true.
                     ncovered=ncovered+1
                  else
                     covered(i1,j1)=.false.
                  endif
               enddo
            enddo
!
            do k1=1,ndist
               j=idist(k1)
!
!                 determine the direction vector in global coordinates
!                  
               do k=1,3
                  dir(k)=(pmid(k,j)-pmid(k,i))/dist(k1)
               enddo
!
!                 direction vector in local coordinates of triangle i
!                  
               dirloc(1)=dir(1)*e1(1,i)+dir(2)*e1(2,i)+dir(3)*e1(3,i)
               dirloc(2)=dir(1)*e2(1,i)+dir(2)*e2(2,i)+dir(3)*e2(3,i)
               dirloc(3)=dir(1)*e3(1,i)+dir(2)*e3(2,i)+dir(3)*e3(3,i)
!
!                 check whether this direction was already covered
!
               ix=int((dirloc(1)+1.d0)/dint)+1
               iy=int((dirloc(2)+1.d0)/dint)+1
               if(covered(ix,iy)) then
                  cycle
               endif
!
!                 calculating the contribution
!
               cospsij=-dir(1)*e3(1,j)-dir(2)*e3(2,j)
     &              -dir(3)*e3(3,j)
               ftij=dirloc(3)*cospsij*area(j)*area(i)/dist(k1)**2
c               write(*,*) i,j,dist(k1),ftij
!
!                 localizing which surface interaction the
!                 triangle interaction is part of (the modulus is
!                 necessary for cyclic structures)
!
               if(j.gt.ntri) then
                  jmod=mod(j,ntri)
                  if(jmod.eq.0) jmod=ntri
               else
                  jmod=j
               endif
!
               call nident(iptri,i,ntr,idi)
               call nident(iptri,jmod,ntr,idj)
               f(idi,idj)=f(idi,idj)+ftij
!
!                 updating the coverage matrix
!
!                 normed local coordinates of the nodes of triangle j
!
               do k=1,3
                  p1(k)=co(k,kontri(1,j))+vold(k,kontri(1,j))-pmid(k,i)
               enddo
               dd=dsqrt(p1(1)*p1(1)+p1(2)*p1(2)+p1(3)*p1(3))
               do k=1,3
                  p1(k)=p1(k)/dd
               enddo
               xx(1)=p1(1)*e1(1,i)+p1(2)*e1(2,i)+p1(3)*e1(3,i)
               yy(1)=p1(1)*e2(1,i)+p1(2)*e2(2,i)+p1(3)*e2(3,i)
!
               do k=1,3
                  p2(k)=co(k,kontri(2,j))+vold(k,kontri(2,j))-pmid(k,i)
               enddo
               dd=dsqrt(p2(1)*p2(1)+p2(2)*p2(2)+p2(3)*p2(3))
               do k=1,3
                  p2(k)=p2(k)/dd
               enddo
               xx(2)=p2(1)*e1(1,i)+p2(2)*e1(2,i)+p2(3)*e1(3,i)
               yy(2)=p2(1)*e2(1,i)+p2(2)*e2(2,i)+p2(3)*e2(3,i)
!
               do k=1,3
                  p3(k)=co(k,kontri(3,j))+vold(k,kontri(3,j))-pmid(k,i)
               enddo
               dd=dsqrt(p3(1)*p3(1)+p3(2)*p3(2)+p3(3)*p3(3))
               do k=1,3
                  p3(k)=p3(k)/dd
               enddo
               xx(3)=p3(1)*e1(1,i)+p3(2)*e1(2,i)+p3(3)*e1(3,i)
               yy(3)=p3(1)*e2(1,i)+p3(2)*e2(2,i)+p3(3)*e2(3,i)
!
               if(dabs(xx(2)-xx(1)).lt.1.d-5) xx(2)=xx(1)+1.d-5
               if(dabs(xx(2)-xx(1)).lt.1.d-5) xx(2)=xx(1)+1.d-5
!
!                 determining maxima and minima
!
               xxmin=2.d0
               xxmax=-2.d0
               do k=1,3
                  if(xx(k).lt.xxmin) then
                     xxmin=xx(k)
                     imin=k
                  endif
                  if(xx(k).gt.xxmax) then
                     xxmax=xx(k)
                     imax=k
                  endif
               enddo
!
               if(((imin.eq.1).and.(imax.eq.2)).or.
     &              ((imin.eq.2).and.(imax.eq.1))) then
                  imid=3
                  xxmid=xx(3)
               elseif(((imin.eq.2).and.(imax.eq.3)).or.
     &                 ((imin.eq.3).and.(imax.eq.2))) then
                  imid=1
                  xxmid=xx(1)
               else
                  imid=2
                  xxmid=xx(2)
               endif
!
!                 check for equal x-values
!
               if(xxmid-xxmin.lt.1.d-5) then
                  xxmin=xxmin-1.d-5
                  xx(imin)=xxmin
               endif
               if(xxmax-xxmid.lt.1.d-5) then
                  xxmax=xxmax+1.d-5
                  xx(imax)=xxmax
               endif
!
!                  equation of the straight lines connecting the
!                  triangle vertices in the local x-y plane
!
               a(1,2)=yy(2)-yy(1)
               b(1,2)=xx(1)-xx(2)
               c(1,2)=yy(1)*xx(2)-xx(1)*yy(2)
!
               a(2,3)=yy(3)-yy(2)
               b(2,3)=xx(2)-xx(3)
               c(2,3)=yy(2)*xx(3)-xx(2)*yy(3)
!
               a(3,1)=yy(1)-yy(3)
               b(3,1)=xx(3)-xx(1)
               c(3,1)=yy(3)*xx(1)-xx(3)*yy(1)
!
               a(2,1)=a(1,2)
               b(2,1)=b(1,2)
               c(2,1)=c(1,2)
               a(3,2)=a(2,3)
               b(3,2)=b(2,3)
               c(3,2)=c(2,3)
               a(1,3)=a(3,1)
               b(1,3)=b(3,1)
               c(1,3)=c(3,1)
!
               istart=int((xxmin+1.d0+dint/2.d0)/dint)+1
               iend=int((xxmid+1.d0+dint/2.d0)/dint)
               do i1=istart,iend
                  x=dint*(i1-0.5d0)-1.d0
                  yymin=-(a(imin,imid)*x+c(imin,imid))/b(imin,imid)
                  yymax=-(a(imin,imax)*x+c(imin,imax))/b(imin,imax)
                  if(yymin.gt.yymax) then
                     dummy=yymin
                     yymin=yymax
                     yymax=dummy
                  endif
                  jstart=int((yymin+1.d0+dint/2.d0)/dint)+1
                  jend=int((yymax+1.d0+dint/2.d0)/dint)
                  do j1=jstart,jend
                     covered(i1,j1)=.true.
                  enddo
                  ncovered=ncovered+jend-jstart+1
               enddo
!
               istart=int((xxmid+1.d0+dint/2.d0)/dint)+1
               iend=int((xxmax+1.d0+dint/2.d0)/dint)
               do i1=istart,iend
                  x=dint*(i1-0.5d0)-1.d0
                  yymin=-(a(imid,imax)*x+c(imid,imax))/b(imid,imax)
                  yymax=-(a(imin,imax)*x+c(imin,imax))/b(imin,imax)
                  if(yymin.gt.yymax) then
                     dummy=yymin
                     yymin=yymax
                     yymax=dummy
                  endif
                  jstart=int((yymin+1.d0+dint/2.d0)/dint)+1
                  jend=int((yymax+1.d0+dint/2.d0)/dint)
                  do j1=jstart,jend
                     covered(i1,j1)=.true.
                  enddo
                  ncovered=ncovered+jend-jstart+1
               enddo
               if(ncovered.eq.ng*ng)exit
!
            enddo
         enddo
!
!        division through total area and through pi
!
         do i=1,ntr
            totarea=0.d0
            if(i.lt.ntr) then
               do j=iptri(i),iptri(i+1)-1
                 totarea=totarea+area(j)
               enddo
            else
               do j=iptri(i),ntri
                  totarea=totarea+area(j)
               enddo
            endif
            totarea=totarea*4.d0*datan(1.d0)
            do j=1,ntr
               f(i,j)=f(i,j)/totarea
            enddo
         enddo
!
!        checking whether the sum of the viewfactors does not
!        exceed 1
!
         do i=1,ntr
            fenv(i)=0.d0
c            f(i,i)=0.d0
            do j=1,ntr
               fenv(i)=fenv(i)+f(i,j)
            enddo
c            write(*,*) nelemload(1,i),',',sideload(i),',',fenv(i),
c     &          ',',1.d0-fenv(i)
            if((fenv(i).gt.1.d0).or.(ienv.eq.0)) then
               do j=1,ntr
                  f(i,j)=f(i,j)/fenv(i)
               enddo
               fenv(i)=1.d0
            endif
            write(*,*) nelemload(1,i),',',sideload(i),',',fenv(i),
     &          ',',1.d0-fenv(i)
            fenv(i)=1.d0-fenv(i)
         enddo
!
         endif
!
!        initialization of ac and bc
!
         do i=1,ntr
            do j=1,ntr
               ac(i,j)=0.d0
            enddo
            bc(i,1)=0.d0
         enddo
!
!        filling ac and bc
!
         do i1=1,ntr
            ac(i1,i1)=1.d0
            i=nloadtr(i1)
            nelem=nelemload(1,i)
            lakonl=lakon(nelem)
!
!              calculate the mean temperature of the face
!
            read(sideload(i)(2:2),'(i1)') ig
!
!              number of nodes and integration points in the face
!
            if(lakonl(4:4).eq.'2') then
               nope=20
               nopes=8
            elseif(lakonl(4:4).eq.'8') then
               nope=8
               nopes=4
            elseif(lakonl(4:5).eq.'10') then
               nope=10
               nopes=6
            elseif(lakonl(4:4).eq.'4') then
               nope=4
               nopes=3
            elseif(lakonl(4:5).eq.'15') then
               nope=15
            else
               nope=6
            endif
!
            if(lakonl(4:5).eq.'8R') then
               mint2d=1
            elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R'))
     &              then
               mint2d=4
            elseif(lakonl(4:4).eq.'2') then
               mint2d=9
            elseif(lakonl(4:5).eq.'10') then
               mint2d=3
            elseif(lakonl(4:4).eq.'4') then
               mint2d=1
            endif
!
            if(lakonl(4:4).eq.'6') then
               mint2d=1
               if(ig.le.2) then
                  nopes=3
               else
                  nopes=4
               endif
            endif
            if(lakonl(4:5).eq.'15') then
               if(ig.le.2) then
                  mint2d=3
                  nopes=6
               else
                  mint2d=4
                  nopes=8
               endif
            endif
!
!              connectivity of the element
!
            index=ipkon(nelem)
            if(index.lt.0) then
               write(*,*) '*ERROR in radflowload: element ',nelem
               write(*,*) '       is not defined'
               stop
            endif
            do k=1,nope
               konl(k)=kon(index+k)
            enddo
!
!              coordinates of the nodes belonging to the face
!
            if((nope.eq.20).or.(nope.eq.8)) then
               do k=1,nopes
                  xl2(0,k)=vold(0,konl(ifaceq(k,ig)))
                  do j=1,3
                     xl2(j,k)=co(j,konl(ifaceq(k,ig)))+
     &                    vold(j,konl(ifaceq(k,ig)))
                  enddo
               enddo
            elseif((nope.eq.10).or.(nope.eq.4)) then
               do k=1,nopes
                  xl2(0,k)=vold(0,konl(ifacet(k,ig)))
                  do j=1,3
                     xl2(j,k)=co(j,konl(ifacet(k,ig)))+
     &                    vold(j,konl(ifacet(k,ig)))
                  enddo
               enddo
            else
               do k=1,nopes
                  xl2(0,k)=vold(0,konl(ifacew(k,ig)))
                  do j=1,3
                     xl2(j,k)=co(j,konl(ifacew(k,ig)))+
     &                    vold(j,konl(ifacew(k,ig)))
                  enddo
               enddo
            endif
!
!              integration to obtain the center of gravity and the mean
!              temperature
!
            areamean=0.d0
            tarea(i1)=0.d0
            do l=1,mint2d
               if((lakonl(4:5).eq.'8R').or.
     &              ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then
                  xi=gauss2d1(1,l)
                  et=gauss2d1(2,l)
                  weight=weight2d1(l)
               elseif((lakonl(4:4).eq.'8').or.
     &                 (lakonl(4:6).eq.'20R').or.
     &                 ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then
                  xi=gauss2d2(1,l)
                  et=gauss2d2(2,l)
                  weight=weight2d2(l)
               elseif(lakonl(4:4).eq.'2') then
                  xi=gauss2d3(1,l)
                  et=gauss2d3(2,l)
                  weight=weight2d3(l)
               elseif((lakonl(4:5).eq.'10').or.
     &                 ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then
                  xi=gauss2d5(1,l)
                  et=gauss2d5(2,l)
                  weight=weight2d5(l)
               elseif((lakonl(4:4).eq.'4').or.
     &                 ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then
                  xi=gauss2d4(1,l)
                  et=gauss2d4(2,l)
                  weight=weight2d4(l)
               endif
!
               if(nopes.eq.8) then
                  call shape8q(xi,et,xl2,xsj2,shp2)
               elseif(nopes.eq.4) then
                  call shape4q(xi,et,xl2,xsj2,shp2)
               elseif(nopes.eq.6) then
                  call shape6tri(xi,et,xl2,xsj2,shp2)
               else
                  call shape3tri(xi,et,xl2,xsj2,shp2)
               endif
!
               dxsj2=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+
     &              xsj2(3)*xsj2(3))
!
               temp=0.d0
               do k=1,3
                  coords(k)=0.d0
               enddo
               do j=1,nopes
                  temp=temp+xl2(0,j)*shp2(4,j)
                  do k=1,3
                     coords(k)=coords(k)+xl2(k,j)*shp2(4,j)
                  enddo
               enddo
!
               tarea(i1)=tarea(i1)+temp*dxsj2*weight
               areamean=areamean+dxsj2*weight
            enddo
            tarea(i1)=tarea(i1)/areamean-physcon(1)
!
!              radiation coefficient
!
            if(sideload(i)(5:6).ne.'NU') then
               erad(i1)=xloadact(1,i)
            else
               read(sideload(i)(2:2),'(i1)') jltyp
               jltyp=jltyp+10
               call radiate(h(1),h(2),temp,istep,
     &              iinc,tvar,nelem,l,coords,jltyp,field,nfield,
     &              sideload(i),node,area,vold)
            endif
!
            e=erad(i1)
            ec=1.d0-e
!
            do j1=1,ntr
               ac(i1,j1)=ac(i1,j1)-ec*f(i1,j1)
c               if(i1.eq.105) write(*,*) f(i1,j1),f(i1+1,j1),f(i1+2,j1)
            enddo
            bc(i1,1)=physcon(2)*(e*tarea(i1)**4+
     &           ec*fenv(i1)*tenv(i1)**4)
c            write(*,*) i1,tarea(i1),erad(i1),fenv(i1),bc(i1,1)
         enddo
!
!        solving the system
!
         nrhs=1
         call dgesv(ntr,nrhs,ac,ntm,ipiv,bc,ntm,info)
         if(info.ne.0) then
            write(*,*) '*ERROR in radflowload: singular matrix'
            stop
         endif
!
!        calculating the flux and transforming the flux into an
!        equivalent temperature
!
         do i=1,ntr
            q=bc(i,1)
            do j=1,ntr
               if(i.eq.j)cycle
               q=q-f(i,j)*bc(j,1)
            enddo
            q=q-fenv(i)*physcon(2)*tenv(i)**4
            xloadact(2,nloadtr(i))=
     &          max(tarea(i)**4-q/(erad(i)*physcon(2)),0.d0)
            xloadact(2,nloadtr(i))=
     &          (xloadact(2,nloadtr(i)))**0.25+physcon(1)
c            write(*,*) i,nelemload(1,i),sideload(i),bc(i,1),q,
c     &          xloadact(2,i)
         enddo
!
      endif
!
      return
      end








