/*
  CalculiX - A 3-dimensional finite element program
  Copyright (C) 1998-2023 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.
*/
/*                                                                       */
/*     author: Reinhold Fischer                                          */

#include <stdio.h>
#include <math.h>
#include <stdlib.h>
#include <string.h>
#include "CalculiX.h"

void dfdbj(double *bcont,double **dbcontp,ITG *neq,ITG *nope,ITG *konl,
	   ITG* nactdof,double *s,double *z,ITG *ikmpc,ITG *ilmpc,
	   ITG *ipompc,ITG *nodempc,ITG *nmpc,double *coefmpc,
	   double *fnl,ITG *nev,ITG **ikactcontp,ITG **ilactcontp,
           ITG *nactcont,ITG *nactcont_,ITG *mi, ITG *cyclicsymmetry,
           ITG *izdof, ITG *nzdof){

  ITG j,j1,jdof,kdof,k,k1,l,id,index,ist,id1,ist1,index1,id2,ist2,index2,
    jdbcontcol,i1,i3,i4,mt=mi[1]+1,im,*ikactcont=*ikactcontp,
    *ilactcont=*ilactcontp,kdofm1;

  double d1,sl,*dbcont=*dbcontp;
  
  for(j=0; j<*nope; j++){
    i1=mt*(konl[j]-1)+1;
    for(j1=0; j1<3; j1++){
      jdof=nactdof[i1+j1];
      if(jdof>0){
	jdof--;
	FORTRAN(nident,(ikactcont,&jdof,nactcont,&id));
	do{
	  if(id>0){
	    if(ikactcont[id-1]==jdof){
	      jdbcontcol=ilactcont[id-1];
	      break;
	    }
	  }
	  (*nactcont)++;
	  if(*nactcont>*nactcont_){
	    *nactcont_=(ITG)(1.1**nactcont_);
	    RENEW(ikactcont,ITG,*nactcont_);
	    RENEW(ilactcont,ITG,*nactcont_);
	    RENEW(dbcont,double,*nev**nactcont_);
	  }
	  k=*nactcont-1;
	  l=k-1;
	  while(k>id){
	    ikactcont[k]=ikactcont[l];
	    ilactcont[k--]=ilactcont[l--];
	  }
	  jdbcontcol=*nactcont;
	  ikactcont[id]=jdof;
	  ilactcont[id]=*nactcont;
	  //		  memset(&dbcont[(*nactcont-1)**nev],0,sizeof(double)**nev);
	  DMEMSET(dbcont,(*nactcont-1)**nev,*nactcont**nev,0.);
	  break;
	}while(1);
	bcont[jdof]-=fnl[j*3+j1];
	i4=(jdbcontcol-1)**nev;
	i3=(3*j+j1);
	for(k=0; k<*nope; k++){
	  for(k1=0; k1<3; k1++){
	    sl=s[(3*k+k1)*60+i3];
	    kdof=nactdof[mt*(konl[k]-1)+k1+1];
	    if(kdof>0){
	      if(!(*cyclicsymmetry)){
		for(l=0; l<*nev; l++){
		  dbcont[i4+l]-=sl*z[(long long)l**neq+kdof-1];
		}
	      }else{
		kdofm1=kdof-1;
		FORTRAN(nident,(izdof,&kdofm1,nzdof,&id));
		if(id!=0){
		  if(izdof[id-1]==kdofm1){
		    for(l=0; l<*nev; l++){
		      dbcont[i4+l]-=sl*z[l**nzdof+id-1];
		    }
		  }else{printf(" *ERROR in dfdbj\n");FORTRAN(stop,());}
		}else{printf(" *ERROR in dfdbj\n");FORTRAN(stop,());}
	      }
	    }
	    else{
	      kdof=8*(konl[k]-1)+k1+1;
	      FORTRAN(nident,(ikmpc,&kdof,nmpc,&id));
	      if(id>0){
		id--;
		if(ikmpc[id]==kdof){
		  id=ilmpc[id];
		  ist=ipompc[id-1];
		  ist--;
		  index=nodempc[ist*3+2];
		  if(index==0) continue;
		  index--;
		  do{
		    kdof=nactdof[mt*(nodempc[index*3]-1)+nodempc[index*3+1]];
		    d1=sl*coefmpc[index]/coefmpc[ist];
		    if(kdof>0){
		      if(!(*cyclicsymmetry)){
			for(l=0; l<*nev; l++){
			  dbcont[i4+l]+=d1*z[(long long)l**neq+kdof-1];
			}
		      }
		    }else{
		      kdofm1=kdof-1;
		      FORTRAN(nident,(izdof,&kdofm1,nzdof,&id));
		      if(id!=0){
			if(izdof[id-1]==kdofm1){
			  for(l=0; l<*nev; l++){
			    dbcont[i4+l]+=d1*z[l**nzdof+id-1];
			  }
			}else{printf(" *ERROR in dfdbj\n");FORTRAN(stop,());}
		      }else{printf(" *ERROR in dfdbj\n");FORTRAN(stop,());}
		    }
		    index=nodempc[index*3+2];
		    if(index==0) break;
		    index--;
		  }while(1);
		}
	      }
	    }
	  }
	}
      }
      else{
	jdof=8*(konl[j]-1)+j1+1;
	FORTRAN(nident,(ikmpc,&jdof,nmpc,&id1));
	if(id1>0){
	  id1--;
	  if(ikmpc[id1]==jdof){
	    id1=ilmpc[id1];
	    ist1=ipompc[id1-1];
	    ist1--;
	    index1=nodempc[ist1*3+2];
	    if(index1==0) continue;
	    index1--;
	    do{
	      jdof=nactdof[mt*(nodempc[index1*3]-1)+nodempc[index1*3+1]];
	      if(jdof>0){
		jdof--;
		FORTRAN(nident,(ikactcont,&jdof,nactcont,&id));
		do{
		  if(id>0){
		    if(ikactcont[id-1]==jdof){
		      jdbcontcol=ilactcont[id-1];
		    }
		  }
		  (*nactcont)++;
		  if(*nactcont>*nactcont_){
		    *nactcont_=(ITG)(1.1**nactcont_);
		    RENEW(ikactcont,ITG,*nactcont_);
		    RENEW(ilactcont,ITG,*nactcont_);
		    RENEW(dbcont,double,*nev**nactcont_);
		  }
		  k=*nactcont-1;
		  l=k-1;
		  do{
		    ikactcont[k]=ikactcont[l];
		    ilactcont[k--]=ilactcont[l--];
		  }while(k>id);
		  jdbcontcol=*nactcont;
		  ikactcont[id]=jdof;
		  ilactcont[id]=*nactcont;
		  //				  memset(&dbcont[(*nactcont-1)**nev],0,sizeof(double)**nev);		  
		  DMEMSET(dbcont,(*nactcont-1)**nev,*nactcont**nev,0.);
		  break;
		}while(1);
		bcont[jdof]+=coefmpc[index1]*fnl[j*3+j1]/coefmpc[ist1];
		i4=(jdbcontcol-1)**nev;
		i3=(3*j+j1);
		for(k=0; k<*nope; k++){
		  for(k1=0; k1<3; k1++){
		    sl=s[(3*k+k1)*60+i3];
		    kdof=nactdof[mt*(konl[k]-1)+k1+1];
		    if(kdof>0){
		      d1=sl*coefmpc[index1]/coefmpc[ist1];
		      if(!(*cyclicsymmetry)){
			for(l=0; l<*nev; l++){
			  dbcont[i4+l]+=d1*z[(long long)l**neq+kdof-1];
			}
		      }else{
			kdofm1=kdof-1;
			FORTRAN(nident,(izdof,&kdofm1,nzdof,&id));
			if(id!=0){
			  if(izdof[id-1]==kdofm1){
			    for(l=0; l<*nev; l++){
			      dbcont[i4+l]+=d1*z[l**nzdof+id-1];
			    }
			  }else{printf(" *ERROR in dfdbj\n");FORTRAN(stop,());}
			}else{printf(" *ERROR in dfdbj\n");FORTRAN(stop,());}
		      }
		    }
		    else{
		      kdof=8*(konl[k]-1)+k1+1;
		      FORTRAN(nident,(ikmpc,&kdof,nmpc,&id2));
		      if(id2>0){
			id2--;
			if(ikmpc[id2]==kdof){
			  id2=ilmpc[id2];
			  ist2=ipompc[id2-1];
			  ist2--;
			  index2=nodempc[ist2*3+2];
			  if(index2==0) continue;
			  index2--;
			  do{
			    kdof=nactdof[mt*(nodempc[index2*3]-1)+nodempc[index2*3+1]];
			    if(kdof>0){
			      d1=sl*coefmpc[index1]*coefmpc[index2]/(coefmpc[ist1]*coefmpc[ist2]);
			      if(!(*cyclicsymmetry)){
				for(l=0; l<*nev; l++){
				  dbcont[i4+l]-=d1*z[(long long)l**neq+kdof-1];
				}
			      }else{
				kdofm1=kdof-1;
				FORTRAN(nident,(izdof,&kdofm1,nzdof,&id));
				if(id!=0){
				  if(izdof[id-1]==kdofm1){
				    for(l=0; l<*nev; l++){
				      dbcont[i4+l]-=d1*z[l**nzdof+id-1];
				    }
				  }else{printf(" *ERROR in dfdbj\n");FORTRAN(stop,());}
				}else{printf(" *ERROR in dfdbj\n");FORTRAN(stop,());}
			      }
			    }
			    index2=nodempc[index2*3+2];
			    if(index2==0) break;
			    index2--;
			  }while(1);
			}
		      }
		    }
		  }
		}
	      }
	      index1=nodempc[index1*3+2];
	      if(index1==0) break;
	      index1--;
	    }while(1);
	  }
	}
      }
    }
  }
  *dbcontp=dbcont;
  *ikactcontp=ikactcont;
  *ilactcontp=ilactcont;
}

/*!
  !     CalculiX - A 3-dimensional finite element program
  !              Copyright (C) 1998-2023 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 dfdbj(bcont,dbcont,neq,nope,konl,nactdof,s,z,
  &  ikmpc,ilmpc,ipompc,nodempc,nmpc,coefmpc,fnl,nev,iactcont,
  &  nactcont)
  !
  !     calculates the derivative of the contact forces with respect
  !     to the modal variables
  !
  implicit none
  !
  integer j,j1,neq,nope,konl(*),nactdof(0:3,*),jdof,kdof,
  &  k,k1,l,id,ikmpc(*),ilmpc(*),ipompc(*),nodempc(3,*),nmpc,
  &  index,ist,id1,ist1,index1,id2,ist2,index2,nev ,iactcont(*),
  &  nactcont,jdofcont
  !
  real*8 bcont(*),dbcont(nev,*),s(60,60),z(neq,*),coefmpc(*),
  &  fnl(3,9)
  !
  do j=1,nope
  do j1=1,3
  jdof=nactdof(j1,konl(j))
  if(jdof.ne.0) then
  call nident(iactcont,jdof,nactcont,id)
  jdofcont=0
  if(id.gt.0)then
  if(iactcont(id).eq.jdof) then
  jdofcont=id
  endif
  endif
  if(jdofcont.eq.0) then
  nactcont=nactcont+1
  do k=nactcont,id+2,-1
  iactcont(k)=iactcont(k-1)
  do l=1,nev
  dbcont(l,k)=dbcont(l,k-1)
  enddo
  enddo
  jdofcont=id+1
  iactcont(jdofcont)=jdof
  do l=1,nev
  dbcont(l,jdofcont)=0.d0
  enddo
  endif
  bcont(jdof)=bcont(jdof)-fnl(j1,j)
  do k=1,nope
  do k1=1,3
  kdof=nactdof(k1,konl(k))
  if(kdof.ne.0) then
  do l=1,nev
  dbcont(l,jdofcont)=dbcont(l,jdofcont)-
  &                       s(3*(j-1)+j1,3*(k-1)+k1)*z(kdof,l)
  enddo
  else
  kdof=8*(konl(k)-1)+k1
  call nident(ikmpc,kdof,nmpc,id)
  if(id.gt.0) then
  if(ikmpc(id).eq.kdof) then
  id=ilmpc(id)
  ist=ipompc(id)
  index=nodempc(3,ist)
  if(index.eq.0) cycle
  do
  kdof=nactdof(nodempc(2,index),
  &                                        nodempc(1,index))
  if(kdof.ne.0) then
  do l=1,nev
  dbcont(l,jdofcont)=
  &                                      dbcont(l,jdofcont)+
  &                                   s(3*(j-1)+j1,3*(k-1)+k1)*
  &                                   coefmpc(index)*z(kdof,l)/
  &                                   coefmpc(ist)
  enddo
  endif
  index=nodempc(3,index)
  if(index.eq.0) exit
  enddo
  endif
  endif
  endif
  enddo
  enddo
  else
  jdof=8*(konl(j)-1)+j1
  call nident(ikmpc,jdof,nmpc,id1)
  if(id1.gt.0) then
  if(ikmpc(id1).eq.jdof) then
  id1=ilmpc(id1)
  ist1=ipompc(id1)
  index1=nodempc(3,ist1)
  if(index1.eq.0) cycle
  do
  jdof=nactdof(nodempc(2,index1),
  &                               nodempc(1,index1))
  if(jdof.ne.0) then
  call nident(iactcont,jdof,nactcont,id)
  jdofcont=0
  if(id.gt.0)then
  if(iactcont(id).eq.jdof) then
  jdofcont=id
  endif
  endif
  if(jdofcont.eq.0) then
  nactcont=nactcont+1
  do k=nactcont,id+2,-1
  iactcont(k)=iactcont(k-1)
  do l=1,nev
  dbcont(l,k)=dbcont(l,k-1)
  enddo
  enddo
  jdofcont=id+1
  iactcont(jdofcont)=jdof
  do l=1,nev
  dbcont(l,jdofcont)=0.d0
  enddo
  endif
  bcont(jdofcont)=bcont(jdofcont)+
  &                          coefmpc(index1)*
  &                          fnl(j1,j)/coefmpc(ist1)
  do k=1,nope
  do k1=1,3
  kdof=nactdof(k1,konl(k))
  if(kdof.ne.0) then
  do l=1,nev
  dbcont(l,jdofcont)=
  &                                      dbcont(l,jdofcont)
  &                                   +s(3*(j-1)+j1,3*(k-1)+k1)
  &                                   *coefmpc(index1)*z(kdof,l)/
  &                                   coefmpc(ist1)
  enddo
  else
  kdof=8*(konl(k)-1)+k1
  call nident(ikmpc,kdof,nmpc,id2)
  if(id2.gt.0) then
  if(ikmpc(id2).eq.kdof) then
  id2=ilmpc(id2)
  ist2=ipompc(id2)
  index2=nodempc(3,ist2)
  if(index2.eq.0) cycle
  do
  !
  !                   translated to the left to avoid exceedance
  !                   of 72 columns
  !
  kdof=nactdof(nodempc(2,index2),
  &                            nodempc(1,index2))
  if(kdof.ne.0) then
  do l=1,nev
  dbcont(l,jdofcont)=dbcont(l,jdofcont)
  &                                  -s(3*(j-1)+j1,3*(k-1)+k1)
  &                                  *coefmpc(index1)
  &                                  *coefmpc(index2)*z(kdof,l)/
  &                                  (coefmpc(ist1)*coefmpc(ist2))
  enddo
  endif
  index2=nodempc(3,index2)
  if(index2.eq.0) exit
  !
  !                   end of translation
  !
  enddo
  endif
  endif
  endif
  enddo
  enddo
  endif
  index1=nodempc(3,index1)
  if(index1.eq.0) exit
  enddo
  endif
  endif
  endif
  enddo
  enddo
  !
  return
  end
*/
