Revision a300fe2b8c94aa973f39d050e5d9ddf04f609e1a authored by M. Helena Gon\xe7alves on 17 February 2013, 00:00:00 UTC, committed by Gabor Csardi on 17 February 2013, 00:00:00 UTC
1 parent e9f9bbd
Raw File
mbgd1i.f
C    loglik.odds.gradient(param,dataset,print.level=0)

      subroutine mbgd1i(gbeta,glpsi,npar,n)
      implicit double precision (a-h,o-z)
      DIMENSION x1(5000,10),theta1(5000),
     *work1(5000),y1(5000),beta1(10),bt1(10),
     *gbeta(10),dbeta(10),dbeta1(10),
     *tpr(2),der1(3),
     *P0(2,2), P1(2,2), P2(2,2),
     *dth(3),db(3,10),der(10)

      double precision lpsi
      integer y1,k,k1,k2,i,i0,i1,i2,j,j1,npar,m,n0,n,mpar

      COMMON/param/x1,theta1,work1,
     *y1,beta1,bt1,m,mpar,omega1,lpsi
      COMMON/grad/ dbeta,dbeta1,der,db
      psi = dexp(lpsi)
      psi1 = psi
      ps1 = psi1-1
      call mati(x1,beta1,work1,5000,10,1,m,mpar+1)
      do 10 k=1,n
        theta1(k) = 1/(1+dexp(-work1(k)))
   10 continue
      i0 = 1 
   20   if (y1(i0).eq.(-1)) then
      i0=i0+1
      go to 20
      end if

      n0 = n
      go to 30
   30   if (y1(n0).eq.(-1)) then
      n0=n0-1
      go to 30
      end if

      p  = theta1(i0)
      do 40 k2=1,(npar-1)
        dbeta1(k2) =  p*(1-p)*x1(i0,k2)
        gbeta(k2)=(y1(i0)/(p*(1-p))-1/(1-p))*dbeta1(k2)    
   40  continue     
      glpsi = 0
      if (i0.eq.n0) return
      gpsi = 0

      i = i0+1
   50 if (i.le.n0) then
      i1=i
   60   if (y1(i1).eq.(-1)) then
      i1=i1+1
      go to 60
      end if

C  i0 is the most recent (past) observation time
C  i1 is the next observation time
      if (i1.eq.i) then
      j  = y1(i0)
      th1 = theta1(i1)
      th2 = theta1(i1-1)
      call mcpj(th1,th2,psi1,tpr)
      p=tpr(y1(i0)+1)
      call deriv(theta1,psi,i1,j,der1)
          dpth  = der1(1)
          dpth1 = der1(2)
          dppsi = der1(3)
          dp = y1(i1)/(p*(1-p))-1/(1-p) 
          do 70 k2=1,(npar-1)
            dbeta(k2) = theta1(i1)*(1-theta1(i1))*x1(i,k2)
            dbeta1(k2) = theta1(i1-1)*(1-theta1(i1-1))*x1(i1-1,k2)
            gbeta(k2) = gbeta(k2) +
     *       dp*(dpth*dbeta(k2)+dpth1*dbeta1(k2))
   70  continue
          gpsi = gpsi+dp*dppsi
        else 
C    (exactly one intermediate missing datum between i0 and i1)
        call mcpj (theta1(i0+1),theta1(i0),psi1,tpr)
        call mat2 (tpr(1),tpr(2),P1)   
        call mcpj (theta1(i1),theta1(i0+1),psi1,tpr)
        call mat2 (tpr(1),tpr(2),P2)  
        call matp(P1,P2,P0,2,2,2)
      j  = y1(i0)
      tpr(1)= P0(1,2)
      tpr(2)= P0(2,2)
      p=tpr(y1(i0)+1)
      dp = y1(i1)/(p*(1-p))-1/(1-p) 
      do 80 k1=0,2
         do 90 k2=1,(npar-1)
           db(k1+1,k2)= theta1(k1+i0)*(1-theta1(k1+i0))*x1(k1+i0,k2)
   90  continue
   80  continue
      call deriv(theta1,psi1,i0+1,j,der1)
      dth(1)=der1(2)*(-P2(1,2)+P2(2,2))      
      dth(2)=der1(1)*(-P2(1,2)+P2(2,2))
      dpsi=der1(3)*(-P2(1,2)+P2(2,2))
      
      call deriv(theta1,psi1,i1,0,der1)
      dth(2)=dth(2)+der1(2)*(1-P1(j+1,2))
      dth(3)=der1(1)*(1-P1(j+1,2))
      dpsi=dpsi+der1(3)*(1-P1(j+1,2))

      call deriv(theta1,psi1,i1,1,der1)
      dth(2)=dth(2)+der1(2)*P1(j+1,2)
      dth(3)=dth(3)+der1(1)*P1(j+1,2)
      dpsi=dpsi+der1(3)*P1(j+1,2)

      do 100 k2=1,(npar-1)
         der(k2)=0.0D0
         do 110 k1=1,3
           der(k2)= der(k2)+dth(k1)*db(k1,k2)
  110  continue
  100  continue
      do 120 k2=1,(npar-1)
           gbeta(k2)= gbeta(k2)+dp*der(k2)
  120  continue
          gpsi = gpsi+dp*dpsi
      end if

        i0=i1
        i=i0+1
      go to 50
      end if
      glpsi=gpsi*psi
      return
      end

back to top