MoDeNa  1.0
Software framework facilitating sequential multi-scale modelling
VLE_subroutines.f90
1 
3 
4 
5 
6 
7 
34 
35  SUBROUTINE start_var(converg)
36 !
37  USE basic_variables
38  USE starting_values
39  IMPLICIT NONE
40 !
41 ! ----------------------------------------------------------------------
42  INTEGER, INTENT(IN OUT) :: converg
43 !
44 ! ----------------------------------------------------------------------
45  INTEGER :: ph, i, k
46  INTEGER :: ncompsav, n_unkwsav, ph_split
47  LOGICAL :: lle_check, flashcase, renormalize
48  REAL :: den1, den2, x_1, x_2
49  CHARACTER (LEN=50) :: filename
50 ! ----------------------------------------------------------------------
51 
52  converg = 0
53 
54  renormalize = .false. ! for renormalization group theory (RGT)
55  IF (num == 2) renormalize = .true.
56  IF (num == 2) num = 0 ! if RGT: initial phase equilibr. is for non-renormalized model
57 
58  flashcase = .false. ! .true. when a specific feed conc. xif is given
59  IF (xif(1) /= 0.0) flashcase = .true.
60 
61  lle_check = .true.
62 
63  DO i=1,ncomp ! setting mole-fractions for the case that
64  ! anything goes wrong in the coming routines
65  xi(1,i) = 1.0 / REAL(ncomp)
66  xi(2,i) = 1.0 / REAL(ncomp)
67  END DO
68 
69 
70  ! ------------------------------------------------------------------
71  ! determine an initial conc. (phase 1) that will phase split
72  ! ------------------------------------------------------------------
73  IF( ncomp == 2 .AND. .NOT.flashcase ) THEN
74  CALL vle_min( lle_check )
75  !WRITE(*,*)' INITIAL FEED-COMPOSITION',(xi(1,i), i=1,ncomp),converg
76  END IF
77 
78  ! ------------------------------------------------------------------
79  ! perform a phase stability test
80  ! ------------------------------------------------------------------
81  ph_split = 0
82  CALL phase_stability ( .false., flashcase, ph_split )
83  !write (*,*) 'stability analysis I indicates phase-split is:',ph_split
84 
85 
86  ! ------------------------------------------------------------------
87  ! determine species i, for which x(i) is calc from summation relation
88  ! ------------------------------------------------------------------
89  CALL select_sum_rel (1,0,1) ! synthax (m,n,o): phase m
90  ! exclude comp. n
91  ! assign it(o) and higher
92  CALL select_sum_rel (2,0,2) ! for ncomp>=3, the quantities
93  ! to be iterated will be overwritten
94 
95  ! ------------------------------------------------------------------
96  ! if 2 phases (VLE)
97  ! ------------------------------------------------------------------
98  IF (ph_split == 1) THEN
99 
100  ! --- perform tangent plane minimization ------------------------
101  CALL tangent_plane
102  ph_split = 0
103 
104  ! --- determine, for which substance summation relation is used --
105  IF (flashcase) THEN
106  CALL determine_flash_it2
107  ELSE
108  CALL select_sum_rel (1,0,1)
109  CALL select_sum_rel (2,0,2)
110  END IF
111 
112  ! --- do full phase equilibr. calculation ------------------------
113  n_unkw = ncomp ! number of quantities to be iterated
114  CALL objective_ctrl (converg)
115  !IF (converg == 1 ) write (*,*) ' converged (maybe a VLE)',dense(1),dense(2)
116 
117  END IF
118 
119  ! ------------------------------------------------------------------
120  ! test for LLE
121  ! ------------------------------------------------------------------
122  ph_split = 0
123 
124  IF (lle_check) CALL phase_stability (lle_check,flashcase,ph_split)
125  !IF (lle_check) write (*,*) 'stability analysis II, phase-split is:',ph_split
126 
127 
128  ! ------------------------------------------------------------------
129  ! if two phases (LLE)
130  ! ------------------------------------------------------------------
131  IF (ph_split == 1) THEN
132 
133  ! write (*,*) ' LLE-stability test indicates 2 phases (VLE or LLE)'
134 
135  ! --- perform tangent plane minimization ------------------------
136  IF (flashcase) CALL select_sum_rel (1,0,1)
137  IF (flashcase) CALL select_sum_rel (2,0,2)
138 
139  CALL tangent_plane
140 
141  ! --- determine, for which substance summation relation ----------
142  IF (flashcase) THEN
143  CALL determine_flash_it2
144  ELSE
145  CALL select_sum_rel (1,0,1)
146  CALL select_sum_rel (2,0,2)
147  END IF
148 
149  ! --- do full phase equilibr. calculation ------------------------
150  n_unkw = ncomp ! number of quantities to be iterated
151  val_conv(2) = 0.0
152  CALL objective_ctrl (converg)
153  ! IF (converg == 1 ) write (*,*) ' converged (maybe an LLE)',dense(1),dense(2)
154 
155  END IF
156 
157  ! ------------------------------------------------------------------
158  ! equilibr. calc. converged: set initial var. for further calc.
159  ! ------------------------------------------------------------------
160  IF (converg == 1) THEN
161  val_init = val_conv
162  DO ph = 1,nphas
163  DO i = 1,ncomp
164  xi(ph,i) = exp( val_conv(4+i+(ph-1)*ncomp) )
165  END DO
166  END DO
167  dense(1:2) = val_conv(1:2)
168  ELSE
169  !WRITE (*,*) ' NO SOLUTION FOUND FOR THE STARTING VALUES'
170  !STOP
171  END IF
172 
173 
174 END SUBROUTINE start_var
175 
176 
177 
178 
212 !
213  SUBROUTINE objective_ctrl (converg)
214 !
215  USE basic_variables
216  USE solve_nonlin
217  IMPLICIT NONE
218 !
219 ! ----------------------------------------------------------------------
220  INTEGER, INTENT(OUT) :: converg
221 !
222 ! ----------------------------------------------------------------------
223  INTERFACE
224  SUBROUTINE objec_fct ( iter_no, y, residu, dummy )
225  INTEGER, INTENT(IN) :: iter_no
226  REAL, INTENT(IN) :: y(iter_no)
227  REAL, INTENT(OUT) :: residu(iter_no)
228  INTEGER, INTENT(IN OUT) :: dummy
229  END SUBROUTINE objec_fct
230  END INTERFACE
231 !
232  INTEGER :: info,k,posn,i
233  INTEGER, PARAMETER :: mxr = nc*(nc+1)/2
234  REAL, ALLOCATABLE :: y(:),diag(:),residu(:)
235  REAL :: x_init, x_solut, r_diff1, r_diff2, totres
236  REAL :: r_thrash, x_thrash
237  CHARACTER (LEN=2) :: compon
238  LOGICAL :: convergence
239 ! ----------------------------------------------------------------------
240 
241 info=1
242 
243 ALLOCATE( y(n_unkw), diag(n_unkw), residu(n_unkw) )
244 
245 IF (num == 0) acc_a = 1.e-7
246 IF (num == 0) step_a = 2.e-8
247 IF (num == 1) acc_a = 1.e-7
248 IF (num == 1) step_a = 2.e-8
249 IF (num == 2) acc_a = 5.e-7
250 IF (num == 2) step_a = 1.e-7
251 
252 posn = 0
253 DO i = 1,n_unkw
254  posn = posn + 1
255  IF (it(i) == 't') y(posn) = val_init(3)
256  IF (it(i) == 'p') y(posn) = val_init(4)
257  IF (it(i) == 'lnp') y(posn) = log( val_init(4) )
258  IF (it(i) == 'fls') y(posn) = alpha
259  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '1') compon = it(i)(3:3)
260  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '1') READ(compon,*) k
261  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '1') y(posn) = val_init(4+k)
262  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '2') compon = it(i)(3:3)
263  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '2') READ(compon,*) k
264  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '2') y(posn) = val_init(4+ncomp+k)
265  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '3') compon = it(i)(3:3)
266  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '3') READ(compon,*) k
267  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '3') y(posn) = val_init(4+ncomp+ncomp+k)
268 END DO
269 
270 CALL init_vars
271 
272 x_init = 0.0
273 DO i = 1,ncomp
274  IF (lnx(1,i) /= 0.0 .AND. lnx(2,i) /= 0.0) THEN
275  x_init = x_init + abs( 1.0 - lnx(2,i)/lnx(1,i) )
276  ELSE
277  x_init = x_init + abs( 1.0 - exp(lnx(2,i))/exp(lnx(1,i)) )
278  END IF
279 END DO
280 
281 CALL hbrd (objec_fct, n_unkw, y, residu, step_a, acc_a, info, diag)
282 
283 x_solut = 0.0
284 DO i = 1,ncomp
285  IF ( lnx(1,i) /= 0.0 .AND. lnx(2,i) /= 0.0 ) THEN
286  x_solut = x_solut + abs( 1.0 - lnx(2,i)/lnx(1,i) )
287  ELSE
288  IF (lnx(1,i) < 1e300 .AND. lnx(1,i) > -1.e300 ) &
289  x_solut = x_solut + abs( 1.0 - exp(lnx(2,i))/exp(lnx(1,i)) )
290  END IF
291 END DO
292 r_diff1 = abs( 1.0 - dense(1)/dense(2) )
293 IF ( val_conv(2) > 0.0 ) THEN
294  r_diff2 = abs( 1.0 - val_conv(1)/val_conv(2) )
295 ELSE
296  r_diff2 = 0.0
297 END IF
298 
299 totres = sum( abs( residu(1:n_unkw) ) )
300 
301 r_thrash = 0.0005
302 x_thrash = 0.0005
303 if (num > 0 ) r_thrash = r_thrash * 10.0
304 if (num > 0 ) x_thrash = x_thrash * 100.0
305 
306 convergence = .true.
307 
308 IF ( info >= 2 ) convergence = .false.
309 IF ( abs( 1.0- dense(1)/dense(2) ) < r_thrash .AND. x_solut < x_thrash ) THEN
310  IF ( x_init > 0.050 ) convergence = .false.
311  IF ( ( abs( 1.0- dense(1)/dense(2) ) + x_solut ) < 1.e-7 ) convergence = .false.
312 ENDIF
313 IF ( r_diff2 /= 0.0 .AND. r_diff2 > (4.0*r_diff1) .AND. bindiag == 1 ) convergence = .false.
314 IF ( ncomp == 1 .AND. totres > 100.0*acc_a ) convergence = .false.
315 IF ( totres > 1000.0*acc_a ) convergence = .false.
316 IF ( ncomp == 1 .AND. r_diff1 < 1.d-5 ) convergence = .false.
317 
318 IF ( convergence ) THEN
319  converg = 1
320  ! write (*,*) residu(1),residu(2)
321  CALL converged
322  IF (num <= 1) CALL enthalpy_etc
323 ELSE
324  converg = 0
325 END IF
326 
327 DEALLOCATE( y, diag, residu )
328 
329 END SUBROUTINE objective_ctrl
330 
331 
332 
346  SUBROUTINE objec_fct ( iter_no, y, residu, dummy )
347 !
348  USE basic_variables
349  USE eos_variables, ONLY: density_error
350  IMPLICIT NONE
351 !
352 ! ----------------------------------------------------------------------
353  INTEGER, INTENT(IN) :: iter_no
354  REAL, INTENT(IN) :: y(iter_no)
355  REAL, INTENT(OUT) :: residu(iter_no)
356  INTEGER, INTENT(IN OUT) :: dummy
357 !
358 ! ----------------------------------------------------------------------
359  INTEGER :: i, ph,k,posn, skip,phase
360  REAL :: lnphi(np,nc),isofugacity
361  CHARACTER (LEN=2) :: compon
362 ! ----------------------------------------------------------------------
363 
364 
365 posn = 0
366 DO i = 1,n_unkw
367  posn = posn + 1
368  IF (it(i) == 't') t = y(posn)
369  IF (it(i) == 'p') p = y(posn)
370  IF (it(i) == 'lnp') p = exp( y(posn) )
371  IF (it(i) == 'fls') alpha = y(posn)
372  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '1') compon = it(i)(3:3)
373  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '1') READ(compon,*) k
374  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '1') lnx(1,k) = y(posn)
375  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '2') compon = it(i)(3:3)
376  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '2') READ(compon,*) k
377  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '2') lnx(2,k) = y(posn)
378  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '3') compon = it(i)(3:3)
379  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '3') READ(compon,*) k
380  IF (it(i)(1:1) == 'x' .AND. it(i)(2:2) == '3') lnx(3,k) = y(posn)
381 END DO
382 
383 DO k = 1,ncomp
384  IF (lnx(1,k) > 0.0) lnx(1,k) = 0.0
385  IF (lnx(2,k) > 0.0) lnx(2,k) = 0.0
386 END DO
387 
388 IF (p < 1.e-100) p = 1.e-12
389 !IF ( IsNaN( p ) ) p = 1000.0 ! rebounce for the case of NaN-solver output
390 !IF ( IsNaN( t ) ) t = 300.0 ! rebounce for the case of NaN-solver output
391 !IF ( IsNaN( alpha ) ) alpha = 0.5 ! rebounce for the case of NaN-solver output
392 IF ( p /= p ) p = 1000.0 ! rebounce for the case of NaN-solver output
393 IF ( t /= t ) t = 300.0 ! rebounce for the case of NaN-solver output
394 IF ( alpha /= alpha ) alpha = 0.5 ! rebounce for the case of NaN-solver output
395 
396 ! --- setting of mole fractions ----------------------------------------
397 DO ph = 1, nphas
398  DO i = 1, ncomp
399  IF ( lnx(ph,i) < -300.0 ) THEN
400  xi(ph,i) = 0.0
401  ELSE
402  xi(ph,i) = exp( lnx(ph,i) )
403  END IF
404  END DO
405 END DO
406 
407 IF (ncomp > 1) CALL x_summation
408 
409 CALL fugacity (lnphi)
410 
411 phase = 2
412 DO i = 1,n_unkw
413  skip = 0 !for ions/polymers, the isofug-eq. is not always solved
414  IF (n_unkw < (ncomp*(nphas-1))) skip = ncomp*(nphas-1) - n_unkw
415  IF ((i+skip-ncomp*(phase-2)) > ncomp) phase = phase + 1
416  residu(i) = isofugacity((i+skip-ncomp*(phase-2)),phase,lnphi)
417  if ( density_error(phase) /= 0.0 ) residu(i) = residu(i) + sign( density_error(phase), residu(i) ) * 0.001
418 END DO
419 
420 END SUBROUTINE objec_fct
421 
422 
423 
431  REAL FUNCTION isofugacity (i,phase,lnphi)
432 !
433  USE basic_variables
434  IMPLICIT NONE
435 !
436 ! ----------------------------------------------------------------------
437  INTEGER, INTENT(IN) :: i
438  INTEGER, INTENT(IN) :: phase
439  REAL, INTENT(IN) :: lnphi(np,nc)
440 !
441 ! ----------------------------------------------------------------------
442  INTEGER :: p1, p2
443 ! ----------------------------------------------------------------------
444 
445 
446 ! p1=1
447 p1 = phase-1
448 p2 = phase
449 
450 isofugacity = scaling(i) *( lnphi(p2,i)+lnx(p2,i)-lnx(p1,i)-lnphi(p1,i) )
451 ! write (*,'(a, 4G18.8)') ' t, p ',t,p,dense(1),dense(2)
452 ! write (*,'(a,i3,i3,3G18.8)') ' phi_V',i,p2,lnx(p2,i),lnphi(p2,i),dense(p2)
453 ! write (*,'(a,i3,i3,3G18.8)') ' phi_L',i,p1,lnx(p1,i),lnphi(p1,i),dense(p1)
454 ! write (*,*) ' ISOFUGACITY',i,ISOFUGACITY, scaling(i)
455 ! write (*,'(a,i3,4G18.8)') ' ISOFUGACITY',i,ISOFUGACITY, lnphi(p2,i)+lnx(p2,i), -lnx(p1,i)-lnphi(p1,i)
456 ! pause
457 
458 END FUNCTION isofugacity
459 
460 
461 
462 
463 
464 
465 
466 
467 
468 
469 
470 
471 
472 
473 
474 
475 
476 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
477 !
478 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
479 !
480  SUBROUTINE vle_min(lle_check)
481 !
482  USE parameters, ONLY: rgas
483  USE basic_variables
484  USE starting_values
485  IMPLICIT NONE
486 !
487 ! ----------------------------------------------------------------------
488  LOGICAL, INTENT(OUT) :: lle_check
489 
490  INTEGER :: i,j,k,phasen(0:40),steps
491  REAL :: lnphi(np,nc)
492  REAL :: vlemin(0:40),llemin(0:40),xval(0:40)
493  REAL :: start_xv(0:40),start_xl(0:40),x_sav,dg_dx2
494 ! ----------------------------------------------------------------------
495 
496 
497 start_xl = 0.
498 start_xv = 0.
499 
500 
501 
502 j = 0
503 k = 0
504 nphas = 2
505 
506 steps = 40
507 
508 x_sav = xi(1,1)
509 sum_rel(1) = 'x12' ! summation relation
510 sum_rel(2) = 'x22' ! summation relation
511 
512 DO i = 0, steps
513  densta(1) = 0.45
514  densta(2) = 1.d-6
515  xi(1,1) = 1.0 - REAL(i) / REAL(steps)
516  IF ( xi(1,1) <= 1.e-50 ) xi(1,1) = 1.e-50
517  xi(2,1) = xi(1,1)
518  lnx(1,1) = log(xi(1,1))
519  lnx(2,1) = log(xi(2,1))
520 
521  CALL x_summation
522  CALL fugacity (lnphi)
523  CALL enthalpy_etc !!KANN DAS RAUS????
524 
525 
526 
527 
528  xval(i) = xi(1,1)
529  llemin(i)= gibbs(1) +(xi(1,1)*lnx(1,1)+xi(1,2)*lnx(1,2))*rgas*t
530 
531  IF ( abs(1.0-dense(1)/dense(2)) > 0.0001 ) THEN
532  vlemin(i)= gibbs(1) +(xi(1,1)*lnx(1,1)+xi(1,2)*lnx(1,2))*rgas*t &
533  - ( gibbs(2) +(xi(2,1)*lnx(2,1)+xi(2,2)*lnx(2,2))*rgas*t )
534  phasen(i) = 2
535  ELSE
536  phasen(i) = 1
537  END IF
538 
539  IF (i > 0 .AND. phasen(i) == 2) THEN
540  IF (phasen(i-1) == 2 .AND. abs(vlemin(i)+vlemin(i-1)) < &
541  abs(vlemin(i))+abs(vlemin(i-1))) THEN
542  j = j + 1
543  start_xv(j)=xval(i-1) + (xval(i)-xval(i-1)) &
544  * abs(vlemin(i-1))/abs(vlemin(i)-vlemin(i-1))
545  END IF
546  END IF
547 
548 END DO
549 
550 
551 DO i=2,steps-2
552  dg_dx2 = (-llemin(i-2)+16.0*llemin(i-1)-30.0*llemin(i) &
553  +16.0*llemin(i+1)-llemin(i+2)) / (12.0*((xval(i)-xval(i-1))**2))
554  IF (dg_dx2 < 0.0) THEN
555  k = k + 1
556  start_xl(k)=xval(i)
557  END IF
558 END DO
559 
560 IF (start_xl(1) == 0.0 .AND. start_xv(1) /= 0.0) THEN
561 
562  xi(1,1) = start_xv(1)
563  xi(1,2) = 1.0-xi(1,1)
564  lle_check=.false.
565  ! write (*,*) 'VLE is likely', xi(1,1),xi(1,2)
566 ELSE IF (start_xl(1) /= 0.0 .AND. start_xv(1) == 0.0) THEN
567 
568  xi(1,1) = start_xl(1)
569  xi(1,2) = 1.0-xi(1,1)
570  ! write (*,*) 'LLE is likely', xi(1,1),xi(1,2)
571  lle_check=.true.
572 ELSE IF (start_xl(1) /= 0.0 .AND. start_xv(1) /= 0.0) THEN
573 
574  xi(1,1) = start_xv(1)
575  xi(1,2) = 1.0-xi(1,1)
576  ! write(*,*) 'starting with VLE and check for LLE'
577  lle_check=.true.
578 ELSE
579 
580  xi(1,1) = x_sav
581  xi(1,2) = 1.0 - xi(1,1)
582 END IF
583 
584 
585 CALL x_summation
586 
587 END SUBROUTINE vle_min
588 
589 
599  SUBROUTINE phase_stability ( lle_check, flashcase, ph_split )
600 !
601  USE basic_variables
602  USE starting_values
603  USE eos_variables, ONLY: dhs, pi, x, eta, eta_start, z3t, fres
604  USE eos_numerical_derivatives
605  IMPLICIT NONE
606 !
607 ! ----------------------------------------------------------------------
608  LOGICAL :: lle_check
609  LOGICAL, INTENT(IN OUT) :: flashcase
610  INTEGER, INTENT(OUT) :: ph_split
611 ! ----------------------------------------------------------------------
612 
613  INTERFACE
614  REAL FUNCTION f_stability ( optpara, n )
615  INTEGER, INTENT(IN) :: n
616  REAL, INTENT(IN OUT) :: optpara(n)
617  END FUNCTION
618  END INTERFACE
619 
620 !INTERFACE
621 ! SUBROUTINE F_STABILITY (fmin, optpara, n)
622 ! REAL, INTENT(IN OUT) :: fmin
623 ! REAL, INTENT(IN) :: optpara(:)
624 ! INTEGER, INTENT(IN) :: n
625 ! END SUBROUTINE F_STABILITY
626 !
627 ! SUBROUTINE stability_grad (g, optpara, n)
628 ! REAL, INTENT(IN OUT) :: g(:)
629 ! REAL, INTENT(IN) :: optpara(:)
630 ! INTEGER, INTENT(IN) :: n
631 ! END SUBROUTINE stability_grad
632 !
633 ! SUBROUTINE stability_hessian (hessian, g, fmin, optpara, n)
634 ! REAL, INTENT(IN OUT) :: hessian(:,:)
635 ! REAL, INTENT(IN OUT) :: g(:)
636 ! REAL, INTENT(IN OUT) :: fmin
637 ! REAL, INTENT(IN) :: optpara(:)
638 ! INTEGER, INTENT(IN) :: n
639 ! END SUBROUTINE stability_hessian
640 !END INTERFACE
641 
642  INTEGER :: n, prin
643  REAL :: fmin, t0, h0, machep, praxis
644  REAL, ALLOCATABLE :: optpara(:)
645 
646  INTEGER :: i, feedphases, trial
647  REAL :: rhoi(nc),rho_start
648  REAL :: feeddens, rho_phas(np)
649  REAL :: fden
650  REAL :: dens
651  REAL :: rhot
652  REAL :: lnphi(np,nc)
653  REAL :: w(np,nc), mean_mass
654 ! ----------------------------------------------------------------------
655 
656 n = ncomp
657 ALLOCATE( optpara(n) )
658 
659 !IF (lle_check) WRITE (*,*) ' stability test starting with dense phase'
660 
661 DO i = 1, ncomp ! setting feed-phase x's
662  IF (.NOT.flashcase) xif(i) = xi(1,i)
663  IF (flashcase) xi(1,i) = xif(i)
664  xi(2,i) = xif(i) ! feed is tested for both: V and L density
665 END DO
666 
667 
668 densta(1) = 0.45
669 densta(2) = 1.d-6
670 
671 CALL dens_calc(rho_phas)
672 IF ( abs(1.0-dense(1)/dense(2)) > 0.0005 ) THEN
673  feedphases=2 ! feed-composition can exist both, in V and L
674 ELSE
675  feedphases=1 ! feed-composition can exist either in V or L
676 END IF
677 densta(1) = dense(1)
678 feeddens = dense(2)
679 !write (*,*) 'feedphases',dense(1), dense(2),feedphases
680 
681 10 CONTINUE ! IF FeedPhases=2 THEN there is a second cycle
682 
683  trial = 1
684 
685  ! --------------------------------------------------------------------
686  ! setting trial-phase mole-fractions
687  ! if there is no phase-split then further trial-phases are
688  ! considered (loop: 20 CONTINUE)
689  ! --------------------------------------------------------------------
690  DO i = 1, ncomp
691  w(2,i) = 1.0 / REAL(ncomp)
692  END DO
693  mean_mass = 1.0 / sum( w(2,1:ncomp)/mm(1:ncomp) )
694  xi(2,1:ncomp) = w(2,1:ncomp)/mm(1:ncomp) * mean_mass
695 
696  20 CONTINUE
697 
698  DO i = 1, ncomp
699  rhoif(i) = rho_phas(1) * xif(i)
700  rhoi(i) = rhoif(i)
701  END DO
702 
703  !write (*,'(a,6G16.8)') 'startval',rho_phas(2),xi(2,1:ncomp)
704 
705  ! --------------------------------------------------------------------
706  ! calc Helmholtz energy density and derivative (numerical) to rhoif(i).
707  ! The derivative is taken around the "feed-point" not the trial phase
708  ! --------------------------------------------------------------------
709 
710  rhot = sum( rhoi(1:ncomp) )
711  x(1:ncomp) = rhoi(1:ncomp) / rhot
712  CALL perturbation_parameter
713  xi(1,1:ncomp) = x(1:ncomp)
714  eta = rhot * z3t
715  eta_start = eta
716  densta(1) = eta_start
717  ensemble_flag = 'tv'
718  CALL fugacity (lnphi)
719  ensemble_flag = 'tp'
720 
721  call fden_calc ( fden, rhoi )
722  fdenf = fden
723 
724  grad_fd(1:ncomp) = lnphi(1,1:ncomp) + log( rhoi(1:ncomp) )
725 
726 
727  ! --------------------------------------------------------------------
728  ! starting values for iteration (optpara)
729  ! --------------------------------------------------------------------
730  rho_start = 1.e-5
731  IF (lle_check) THEN
732  densta(2) = 0.45
733  CALL dens_calc(rho_phas)
734  rho_start = rho_phas(2)*0.45/dense(2)
735  END IF
736  DO i = 1,ncomp
737  rhoi(i) = xi(2,i)*rho_start
738  optpara(i) = log( rhoi(i) )
739  END DO
740 
741  ! --------------------------------------------------------------------
742  ! minimizing the objective fct. Phase split for values of fmin < 0.0
743  ! --------------------------------------------------------------------
744  t0 = 5.e-5
745  h0 = 0.5
746  prin = 0
747  machep = 1.e-15
748 
749  fmin = praxis( t0, machep, h0, n, prin, optpara, f_stability, fmin )
750 
751 
752  ! --------------------------------------------------------------------
753  ! updating the ln(x) valus from optpara. The optimal optpara-vector is
754  ! not necessarily the one that was last evaluated. At the very end,
755  ! cg_decent writes the best values to optpara
756  ! --------------------------------------------------------------------
757  fmin = f_stability( optpara, n )
758 
759 
760 
761  ! IF ( n == 2 ) THEN
762  ! CALL Newton_Opt_2D ( stability_hessian, F_stability, optpara, n, 1.E-8, 1.E-8, g, fmin)
763  ! ELSE
764  ! CALL cg_descent (1.d-5, optpara, n, F_STABILITY, stability_grad, STATUS, &
765  ! gnorm, fmin, iter, nfunc, ngrad, d, g, xtemp, gtemp)
766  ! ENDIF
767  ! CALL F_STABILITY (fmin, optpara, n)
768 
769 
770  ! --------------------------------------------------------------------
771  ! determine instability & non-trivial solution
772  ! --------------------------------------------------------------------
773  ph_split = 0
774  IF (fmin < -1.e-7 .AND. &
775  abs( 1.0 - maxval(exp(optpara),mask=optpara /= 0.0) /maxval(rhoif) ) > 0.0005) THEN
776  ph_split = 1
777  END IF
778 
779  IF (ph_split == 1) THEN
780 
781  ! ------------------------------------------------------------------
782  ! here, there should be IF FeedPhases=2 THEN GOTO 10
783  ! and test for another phase (while saving optpara)
784  ! ------------------------------------------------------------------
785 
786  rhoi2(1:ncomp) = exp( optpara(1:ncomp) )
787  dens = pi/6.0 * sum( rhoi2(1:ncomp) * parame(1:ncomp,1) * dhs(1:ncomp)**3 )
788  rhot = sum( rhoi2(1:ncomp) )
789  xi(2,1:ncomp) = rhoi2(1:ncomp) / rhot
790 
791  ELSE
792 
793  IF (trial <= ncomp + ncomp) THEN
794  ! ----------------------------------------------------------------
795  ! setting trial-phase x's
796  ! ----------------------------------------------------------------
797  IF (trial <= ncomp) THEN
798  DO i=1,ncomp
799  w(2,i) = 1.0 / REAL(ncomp-1) * 0.05
800  END DO
801  w(2,trial) = 0.95
802  ELSE
803  DO i=1,ncomp
804  w(2,i) = 1.0 / REAL(ncomp-1) * 0.00001
805  END DO
806  w(2,trial-ncomp) = 0.99999
807  END IF
808  mean_mass = 1.0 / sum( w(2,1:ncomp)/mm(1:ncomp) )
809  xi(2,1:ncomp) = w(2,1:ncomp)/mm(1:ncomp) * mean_mass
810  trial = trial + 1
811  GO TO 20
812  END IF
813  ! IF (.NOT.LLE_check) write (*,*) 'no phase split detected'
814  ! IF (.NOT.LLE_check) pause
815  IF (feedphases > 1 .AND. .NOT.lle_check .AND. densta(1) > 0.2) THEN
816  densta(1) = feeddens ! this will be the lower-valued density (vapor)
817  CALL dens_calc(rho_phas)
818  ! WRITE (*,*) 'try feed as vapor-phase'
819  GO TO 10
820  END IF
821 
822  END IF
823 
824 DEALLOCATE( optpara )
825 
826 END SUBROUTINE phase_stability
827 
828 
850 !
851  SUBROUTINE select_sum_rel (ph,excl,startindex)
852 !
853  USE basic_variables
854  IMPLICIT NONE
855 !
856 ! ----------------------------------------------------------------------
857  INTEGER, INTENT(IN) :: ph
858  INTEGER, INTENT(IN) :: excl
859  INTEGER, INTENT(IN) :: startindex
860 ! ----------------------------------------------------------------------
861  INTEGER :: i,j, sum_index
862  REAL :: xmax(np)
863  ! CHARACTER :: compNo*2,phasNo*2
864 ! ----------------------------------------------------------------------
865 
866 xmax(ph) = 0.0
867 DO i = 1, ncomp
868 
869  IF ( xi(ph,i) > xmax(ph) ) THEN
870  xmax(ph) = xi(ph,i)
871  sum_index = i
872 
873  IF (ph == 1 .AND. i == 1) sum_rel(1) = 'x11'
874  IF (ph == 1 .AND. i == 2) sum_rel(1) = 'x12'
875  IF (ph == 1 .AND. i == 3) sum_rel(1) = 'x13'
876  IF (ph == 1 .AND. i == 4) sum_rel(1) = 'x14'
877  IF (ph == 1 .AND. i == 5) sum_rel(1) = 'x15'
878 
879  IF (ph == 2 .AND. i == 1) sum_rel(2) = 'x21'
880  IF (ph == 2 .AND. i == 2) sum_rel(2) = 'x22'
881  IF (ph == 2 .AND. i == 3) sum_rel(2) = 'x23'
882  IF (ph == 2 .AND. i == 4) sum_rel(2) = 'x24'
883  IF (ph == 2 .AND. i == 5) sum_rel(2) = 'x25'
884 
885  IF (ph == 3 .AND. i == 1) sum_rel(3) = 'x31'
886  IF (ph == 3 .AND. i == 2) sum_rel(3) = 'x32'
887  IF (ph == 3 .AND. i == 3) sum_rel(3) = 'x33'
888  IF (ph == 3 .AND. i == 4) sum_rel(3) = 'x34'
889  IF (ph == 3 .AND. i == 5) sum_rel(3) = 'x35'
890 ! write (*,*) ph,i,xi(ph,i),sum_rel(ph)
891  END IF
892 
893 END DO
894 
895 j = 0
896 DO i = 1, ncomp
897 
898  IF ( i /= sum_index .AND. i /= excl ) THEN
899  IF (ph == 1 .AND. i == 1) it(startindex+j) = 'x11'
900  IF (ph == 1 .AND. i == 2) it(startindex+j) = 'x12'
901  IF (ph == 1 .AND. i == 3) it(startindex+j) = 'x13'
902  IF (ph == 1 .AND. i == 4) it(startindex+j) = 'x14'
903  IF (ph == 1 .AND. i == 5) it(startindex+j) = 'x15'
904 
905  IF (ph == 2 .AND. i == 1) it(startindex+j) = 'x21'
906  IF (ph == 2 .AND. i == 2) it(startindex+j) = 'x22'
907  IF (ph == 2 .AND. i == 3) it(startindex+j) = 'x23'
908  IF (ph == 2 .AND. i == 4) it(startindex+j) = 'x24'
909  IF (ph == 2 .AND. i == 5) it(startindex+j) = 'x25'
910 
911  IF (ph == 3 .AND. i == 1) it(startindex+j) = 'x31'
912  IF (ph == 3 .AND. i == 2) it(startindex+j) = 'x32'
913  IF (ph == 3 .AND. i == 3) it(startindex+j) = 'x33'
914  IF (ph == 3 .AND. i == 4) it(startindex+j) = 'x34'
915  IF (ph == 3 .AND. i == 5) it(startindex+j) = 'x35'
916 ! write (*,*) 'iter ',it(startindex+j)
917  j = j + 1
918  END IF
919 
920 END DO
921 
922 END SUBROUTINE select_sum_rel
923 
924 
925 
926 
927 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
928 !
929 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
930 !
931  SUBROUTINE tangent_plane
932 !
933  USE basic_variables
934  USE starting_values
935  IMPLICIT NONE
936 !
937 ! ----------------------------------------------------------------------
938 !!$ INTERFACE
939 !!$ SUBROUTINE tangent_value (fmin, optpara, n)
940 !!$ INTEGER, INTENT(IN) :: n
941 !!$ REAL, INTENT(IN OUT) :: fmin
942 !!$ REAL, INTENT(IN) :: optpara(:)
943 !!$ END SUBROUTINE tangent_value
944 !!$
945 !!$ SUBROUTINE tangent_grad (g, optpara, n)
946 !!$ INTEGER, INTENT(IN) :: n
947 !!$ REAL, INTENT(IN OUT) :: g(:)
948 !!$ REAL, INTENT(IN) :: optpara(:)
949 !!$ END SUBROUTINE tangent_grad
950 !!$ END INTERFACE
951 
952 !
953 ! ----------------------------------------------------------------------
954  INTERFACE
955  REAL FUNCTION praxis( t0, MACHEP, h0, n, PRIN, optpara, TANGENT_VALUE, fmin )
956  REAL, INTENT(IN OUT) :: t0
957  REAL, INTENT(IN) :: machep
958  REAL, INTENT(IN) :: h0
959  INTEGER :: n
960  INTEGER, INTENT(IN OUT) :: prin
961  REAL, INTENT(IN OUT) :: optpara(n)
962  REAL, EXTERNAL :: tangent_value
963  REAL, INTENT(IN OUT) :: fmin
964  END FUNCTION
965 
966  REAL FUNCTION tangent_value2 ( optpara, n )
967  INTEGER, INTENT(IN) :: n
968  REAL, INTENT(IN) :: optpara(n)
969  END FUNCTION
970  END INTERFACE
971 !
972 ! ----------------------------------------------------------------------
973  INTEGER :: n
974  INTEGER :: i, k, ph
975  INTEGER :: small_i, min_ph, other_ph
976  INTEGER :: prin
977  REAL :: fmin , t0, h0, machep
978  REAL :: lnphi(np,nc)
979  REAL, ALLOCATABLE :: optpara(:)
980 
981 ! INTEGER :: STATUS, iter, nfunc, ngrad
982 ! REAL :: gnorm
983 ! REAL, ALLOCATABLE :: d(:), g(:), xtemp(:), gtemp(:)
984 ! ----------------------------------------------------------------------
985 
986 n = ncomp
987 t0 = 1.e-4
988 h0 = 0.1
989 prin = 0
990 machep = 1.e-15
991 
992 ALLOCATE( optpara(n) )
993 !ALLOCATE( d(n) )
994 !ALLOCATE( g(n) )
995 !ALLOCATE( xtemp(n) )
996 !ALLOCATE( gtemp(n) )
997 
998 DO i = 1,ncomp
999  rhoi1(i) = rhoif(i)
1000  lnx(1,i) = log(xi(1,i))
1001  lnx(2,i) = log(xi(2,i))
1002 END DO
1003 
1004 DO i = 1,ncomp
1005  optpara(i) = log( xi(2,i) * 0.001 )
1006 END DO
1007 
1008 ! CALL cg_descent (1.d-4, optpara, n, tangent_value, tangent_grad, STATUS, &
1009 ! gnorm, fmin, iter, nfunc, ngrad, d, g, xtemp, gtemp)
1010 !
1011 ! updating the ln(x) valus from optpara. The optimal optpara-vector is not necessarily
1012 ! the one that was last evaluated. At the very end, cg_decent writes the best values to optpara
1013 ! CALL tangent_value (fmin, optpara, n)
1014 
1015 
1016 
1017 fmin = praxis( t0, machep, h0, n, prin, optpara, tangent_value2, fmin )
1018 
1019 ! The optimal optpara-vector is not necessarily the one that was last evaluated.
1020 ! TANGENT_VALUE is reexecuted with the optimal vector optpara, in order to update the ln(x) values
1021 fmin = tangent_value2( optpara, n )
1022 
1023 
1024 ! ----------------------------------------------------------------------
1025 ! If one component is a polymer (indicated by a low component-density)
1026 ! then get an estimate of the polymer-lean composition, by solving for
1027 ! xi_p1 = ( xi_p2 * phii_p2) / phii_p1 (phase equilibrium condition,
1028 ! with p1 for phase 1)
1029 ! ----------------------------------------------------------------------
1030 IF ( minval( lnx(1,1:ncomp) ) < minval( lnx(2,1:ncomp) ) ) THEN
1031  min_ph = 1
1032  other_ph = 2
1033 ELSE
1034  min_ph = 2
1035  other_ph = 1
1036 ENDIF
1037 small_i = minloc( lnx(min_ph,1:ncomp), 1 )
1038 ! --- if one component is a polymer ------------------------------------
1039 IF ( minval( lnx(min_ph,1:ncomp) ) < -20.0 ) THEN
1040  CALL fugacity ( lnphi )
1041  lnx(min_ph,small_i) = lnx(other_ph,small_i)+lnphi(other_ph,small_i) - lnphi(min_ph,small_i)
1042  optpara(small_i) = lnx(2,small_i) + log( sum( exp( optpara(1:ncomp) ) ) )
1043 END IF
1044 
1045 ! ----------------------------------------------------------------------
1046 ! caution: these initial values are for a flashcase overwritten in
1047 ! SUBROUTINE determine_flash_it2, because in that case, the lnx-values
1048 ! treated as ln(mole_number).
1049 ! ----------------------------------------------------------------------
1050 val_init(1) = dense(1)
1051 val_init(2) = dense(2)
1052 val_init(3) = t
1053 val_init(4) = p
1054 DO ph = 1,nphas
1055  DO k = 1,ncomp
1056  val_init(4+k+(ph-1)*ncomp) = lnx(ph,k)
1057  END DO
1058 END DO
1059 !alpha = optpara(1)
1060 
1061 
1062 !DEALLOCATE( optpara, d, g, xtemp, gtemp )
1063 DEALLOCATE( optpara )
1064 
1065 END SUBROUTINE tangent_plane
1066 
1067 
1068 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1069 !
1070 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1071 !
1072  SUBROUTINE determine_flash_it2
1073 !
1074  USE basic_variables
1075  IMPLICIT NONE
1076 !
1077 ! ----------------------------------------------------------------------
1078  INTEGER :: i, k, ph
1079  REAL :: n_phase1, n_phase2, max_x_diff
1080 ! ----------------------------------------------------------------------
1081 
1082  IF ( minval( lnx(1,1:ncomp) ) < minval( lnx(2,1:ncomp) ) ) THEN
1083  it(1) = 'x11'
1084  it(2) = 'x12'
1085  IF (ncomp >= 3) it(3) = 'x13'
1086  IF (ncomp >= 4) it(4) = 'x14'
1087  IF (ncomp >= 5) it(5) = 'x15'
1088  sum_rel(1) = 'nfl'
1089  ELSE
1090  it(1) = 'x21'
1091  it(2) = 'x22'
1092  IF (ncomp >= 3) it(3) = 'x23'
1093  IF (ncomp >= 4) it(4) = 'x24'
1094  IF (ncomp >= 5) it(5) = 'x25'
1095  sum_rel(2) = 'nfl'
1096  ENDIF
1097  max_x_diff = 0.0
1098  DO i = 1,ncomp
1099  IF ( abs( exp( lnx(1,i) ) - exp( lnx(2,i) ) ) > max_x_diff ) THEN
1100  max_x_diff = abs( exp( lnx(1,i) ) - exp( lnx(2,i) ) )
1101  n_phase1 = ( xif(i) - exp( lnx(2,i) ) ) / ( exp( lnx(1,i) ) - exp( lnx(2,i) ) )
1102  n_phase2 = 1.0 - n_phase1
1103  END IF
1104  END DO
1105  lnx(1,1:ncomp) = lnx(1,1:ncomp) + log( n_phase1 ) ! these x's are treated as mole numbers
1106  lnx(2,1:ncomp) = lnx(2,1:ncomp) + log( n_phase2 ) ! these x's are treated as mole numbers
1107 
1108 
1109  val_init(1) = dense(1)
1110  val_init(2) = dense(2)
1111  val_init(3) = t
1112  val_init(4) = p
1113  DO ph = 1,nphas
1114  DO k = 1,ncomp
1115  val_init(4+k+(ph-1)*ncomp) = lnx(ph,k) ! - LOG( SUM( EXP( lnx(ph,1:ncomp) ) ) )
1116  ! write (*,*) ph,k, lnx(ph,k)
1117  END DO
1118  END DO
1119 
1120 END SUBROUTINE determine_flash_it2
1121 
1122 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1123 ! SUBROUTINE poly_sta_var
1124 !
1125 ! This subroutine generates starting values for mole fractons of
1126 ! polymer-solvent systems.
1127 ! The determination of these starting values follows a two-step
1128 ! procedure. Fist, the equilibrium concentration of the polymer-rich
1129 ! phase is estimated with the assumption of zero concentration
1130 ! of polymer in the polymer-lean-phase. This is achieved in the
1131 ! SUBROUTINE POLYMER_FREE. (Only one equation has to be iterated
1132 ! for this case). Once this is achieved, the rigorous calculation
1133 ! is triggered. If it converges, fine! If no solution is obtained,
1134 ! the pressure is somewhat reduced, the procedure is repeated and
1135 ! a calculation is started to approach the originally specified
1136 ! pressure.
1137 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1138 !
1139  SUBROUTINE poly_sta_var (converg)
1140 !
1141  USE basic_variables
1142  IMPLICIT NONE
1143 !
1144 ! ----------------------------------------------------------------------
1145  INTEGER, INTENT(IN OUT) :: converg
1146 !
1147 ! ----------------------------------------------------------------------
1148  INTEGER :: k,ph,sol
1149  REAL :: p_spec,solution(10,4+nc*np)
1150 ! ----------------------------------------------------------------------
1151 
1152  p_spec = p
1153 
1154  find_equilibrium: DO
1155 
1156  CALL polymer_free(p_spec,sol,solution)
1157 
1158  WRITE (*,*) ' '
1159  WRITE (*,*) ' GENERATING STARTING VALUES'
1160 
1161  val_init(1) = solution(1,1) ! approx.solutions for next iteration
1162  val_init(2) = solution(1,2) ! approx.solutions for next iteration
1163  val_init(3) = solution(1,3) ! approx.solutions for next iteration
1164  val_init(4) = solution(1,4) ! approx.solutions for next iteration
1165  DO ph = 1,nphas
1166  DO k = 1,ncomp
1167  val_init(4+k+(ph-1)*ncomp) = solution(1,4+k+(ph-1)*ncomp)
1168  END DO
1169  END DO
1170  val_init(7) = -10000.0 ! start.val. for lnx(2,1) for iterat.
1171 
1172  IF (p /= p_spec) &
1173  WRITE (*,*) ' INITIAL EQUILIBRIUM CALC. FAILD. NEXT STEP STARTS'
1174 
1175  IF (p == p_spec) THEN
1176  n_unkw = ncomp ! number of quantities to be iterated
1177  it(1)='x11' ! iteration of mol fraction of comp.1 phase 1
1178  it(2)='x21' ! iteration of mol fraction of comp.1 phase 2
1179  CALL objective_ctrl (converg)
1180  ELSE
1181  outp = 0 ! output to terminal
1182  running ='p' ! Pressure is running var. in PHASE_EQUILIB
1183  CALL phase_equilib(p_spec,5.0,converg)
1184  END IF
1185 
1186  IF (converg == 1) EXIT find_equilibrium
1187  p = p * 0.9
1188  IF ( p < (0.7*p_spec) ) WRITE (*,*) ' NO SOLUTION FOUND'
1189  IF ( p < (0.7*p_spec) ) stop
1190 
1191  END DO find_equilibrium
1192 
1193  WRITE (*,*) ' FINISHED: POLY_STA_VAR'
1194 
1195 END SUBROUTINE poly_sta_var
1196 
1197 
1213  SUBROUTINE x_summation
1214 !
1215  USE basic_variables
1216  IMPLICIT NONE
1217 !
1218 ! ----------------------------------------------------------------------
1219  INTEGER :: i, j, comp_i, ph_i
1220  REAL :: sum_x
1221  CHARACTER (LEN=2) :: phasno
1222  CHARACTER (LEN=2) :: compno
1223  LOGICAL :: flashcase2
1224 ! ----------------------------------------------------------------------
1225 
1226 DO j = 1, nphas
1227  IF (sum_rel(j)(1:3) == 'nfl') THEN
1228  CALL new_flash (j)
1229  RETURN
1230  END IF
1231 END DO
1232 
1233 
1234 
1235 flashcase2 = .false.
1236 
1237 DO j = 1, nphas
1238 
1239  IF (sum_rel(j)(1:1) == 'x') THEN
1240 
1241  phasno = sum_rel(j)(2:2)
1242  READ(phasno,*) ph_i
1243  compno = sum_rel(j)(3:3)
1244  READ(compno,*) comp_i
1245  IF ( sum_rel(nphas+j)(1:1) == 'e' ) CALL neutr_charge(nphas+j)
1246 
1247  sum_x = 0.0
1248  DO i = 1, ncomp
1249  IF ( i /= comp_i ) sum_x = sum_x + xi(ph_i,i)
1250  END DO
1251  xi(ph_i,comp_i) = 1.0 - sum_x
1252  IF ( xi(ph_i,comp_i ) < 0.0 ) xi(ph_i,comp_i) = 0.0
1253  IF ( xi(ph_i,comp_i ) /= 0.0 ) THEN
1254  lnx(ph_i,comp_i) = log( xi(ph_i,comp_i) )
1255  ELSE
1256  lnx(ph_i,comp_i) = -100000.0
1257  END IF
1258  ! write (*,*) 'sum_x',ph_i,comp_i,lnx(ph_i,comp_i),xi(ph_i,comp_i)
1259 
1260  ELSE IF ( sum_rel(j)(1:2) == 'fl' ) THEN
1261 
1262  flashcase2 = .true.
1263  ! ------------------------------------------------------------------
1264  ! This case is true when all molefractions of one phase are
1265  ! determined from a component balance. What is needed to
1266  ! calculate all molefractions of that phase are all mole-
1267  ! fractions of the other phase (nphas=2, so far) and the
1268  ! phase fraction alpha.
1269  ! Alpha is calculated (in FLASH_ALPHA) from the mole fraction
1270  ! of component {sum_rel(j)(3:3)}. IF sum_rel(2)='fl3', then
1271  ! the alpha is determined from the molefraction of comp. 3 and
1272  ! the molefraction of phase 2 is then completely determined ELSE
1273  ! ------------------------------------------------------------------
1274 
1275  ELSE
1276  WRITE (*,*) 'summation relation not defined'
1277  stop
1278  END IF
1279 
1280 END DO
1281 
1282 IF ( it(1) == 'fls' ) CALL flash_sum
1283 IF ( flashcase2 ) CALL flash_alpha
1284 
1285 END SUBROUTINE x_summation
1286 
1287 
1288 
1305  SUBROUTINE fugacity (ln_phi)
1306 !
1307  USE basic_variables
1308  USE eos_variables, ONLY: phas, x, eta, eta_start, lnphi, fres, rho, pges, kbol
1309  IMPLICIT NONE
1310 !
1311 ! ----------------------------------------------------------------------
1312  REAL, INTENT(OUT) :: ln_phi(np,nc)
1313 !
1314 ! --- local variables --------------------------------------------------
1315  INTEGER :: ph
1316 ! ----------------------------------------------------------------------
1317 !
1318 IF (eos < 2) THEN
1319 
1320  DO ph = 1,nphas
1321 
1322  phas = ph
1323  eta_start = densta(ph)
1324  x(1:ncomp) = xi(ph,1:ncomp)
1325 
1326  IF (p < 1.e-100) THEN
1327  WRITE(*,*) ' FUGACITY: PRESSURE TOO LOW', p
1328  p = 1.e-6
1329  END IF
1330 
1331  IF (num == 0) CALL phi_eos
1332  IF (num == 1) CALL phi_numerical
1333  !!IF (num == 2) CALL PHI_CRITICAL_RENORM
1334  IF (num == 2) write(*,*) 'CRITICAL RENORM NOT INCLUDED YET'
1335 
1336  dense(ph) = eta
1337  ln_phi(ph,1:ncomp) = lnphi(1:ncomp)
1338  ! gibbs(ph) = fres + sum( xi(ph,1:ncomp)*( log( xi(ph,1:ncomp)*rho) - 1.0 ) ) &
1339  ! + (pges * 1.d-30) / (KBOL*t*rho) ! includes ideal gas contribution
1340 
1341  ! f_res(ph) = fres
1342  ! write (*,'(i3,4G20.11)') ph,eta,lnphi(1),lnphi(2)
1343  ! DO i = 1,ncomp
1344  ! DO j=1,NINT(parame(i,12))
1345  ! mxx(ph,i,j) = mx(i,j)
1346  ! END DO
1347  ! END DO
1348 
1349  END DO
1350 
1351 ELSE
1352 
1353 ! IF (eos == 2) CALL srk_eos (ln_phi)
1354 ! IF (eos == 3) CALL pr_eos (ln_phi)
1355 ! dense(1) = 0.01
1356 ! dense(2) = 0.3
1357 ! IF (eos == 4.OR.eos == 5.OR.eos == 6.OR.eos == 8) CALL lj_fugacity(ln_phi)
1358 ! IF (eos == 7) CALL sw_fugacity(ln_phi)
1359 ! IF (eos == 9) CALL lj_bh_fug(ln_phi)
1360 
1361 END IF
1362 
1363 END SUBROUTINE fugacity
1364 
1365 
1366 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1367 ! SUBROUTINE enthalpy_etc
1368 !
1369 ! This subroutine serves as an interface to the EOS-routines. The
1370 ! residual enthalpy h_res, residual entropy s_res, residual Gibbs
1371 ! enthalpy g_res, and residual heat capacity at constant pressure
1372 ! (cp_res) corresponding to converged conditions are calculated.
1373 ! The conditions in (T,P,xi,rho) need to be converged equilibrium
1374 ! conditions !!
1375 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1376 !
1377  SUBROUTINE enthalpy_etc
1378 !
1379  USE basic_variables
1380  USE eos_variables
1381  IMPLICIT NONE
1382 !
1383  INTEGER :: ph
1384 ! ------------------------------------------------------------------
1385 
1386 IF (eos <= 1) THEN
1387 
1388  DO ph=1,nphas
1389 
1390  phas = ph
1391  eta = dense(ph)
1392 ! eta_start = dense(ph)
1393  x(1:ncomp) = xi(ph,1:ncomp)
1394 
1395  IF(num == 0) THEN
1396  CALL h_eos
1397  ELSE
1398  IF(num == 1) CALL h_numerical
1399  IF(num == 2) write (*,*) 'enthalpy_etc: incorporate H_EOS_RN'
1400  IF(num == 2) stop
1401 ! IF(num == 2) CALL H_EOS_rn
1402  END IF
1403  enthal(ph) = h_res
1404  entrop(ph) = s_res
1405  ! gibbs(ph) = h_res - t * s_res ! already defined in eos.f90 (including ideal gas)
1406  cpres(ph) = cp_res
1407 
1408  END DO
1409  IF (nphas == 2) h_lv = enthal(2)-enthal(1)
1410 
1411 ENDIF
1412 
1413 END SUBROUTINE enthalpy_etc
1414 
1415 
1424  SUBROUTINE dens_calc(rho_phas)
1425 !
1426  USE basic_variables
1427  USE eos_variables
1428  IMPLICIT NONE
1429 !
1430 !
1431 !------------------------------------------------------------------
1432  REAL, INTENT(OUT) :: rho_phas(np)
1433 !
1434  INTEGER :: ph
1435 !------------------------------------------------------------------
1436 
1437 
1438 DO ph = 1, nphas
1439 
1440  IF (eos < 2) THEN
1441 
1442  phas = ph
1443  eta = densta(ph)
1444  eta_start = densta(ph)
1445  x(1:ncomp) = xi(ph,1:ncomp)
1446 
1447  CALL perturbation_parameter
1448  CALL density_iteration
1449 
1450  dense(ph)= eta
1451  rho_phas(ph) = eta/z3t
1452 
1453  ELSE
1454  write (*,*) ' SUBROUTINE DENS_CALC not available for cubic EOS'
1455  stop
1456  END IF
1457 
1458 END DO
1459 
1460 END SUBROUTINE dens_calc
1461 
1462 
1463 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1464 !
1465 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1466 !
1467  SUBROUTINE fden_calc (fden, rhoi)
1468 !
1469  USE basic_variables
1470  USE eos_variables
1471  IMPLICIT NONE
1472 !
1473 ! ----------------------------------------------------------------------
1474  REAL, INTENT(OUT) :: fden
1475  REAL, INTENT(IN OUT) :: rhoi(nc)
1476 ! ----------------------------------------------------------------------
1477  REAL :: rhot, fden_id
1478 ! ----------------------------------------------------------------------
1479 
1480 
1481 IF (eos < 2) THEN
1482 
1483  rhot = sum( rhoi(1:ncomp) )
1484  x(1:ncomp) = rhoi(1:ncomp) / rhot
1485 
1486  CALL perturbation_parameter
1487  eta = rhot * z3t
1488  eta_start = eta
1489 
1490  IF (num == 0) THEN
1491  CALL f_eos
1492  ELSE IF(num == 1) THEN
1493  CALL f_numerical
1494  ELSE
1495  write (*,*) 'deactivated this line when making a transition to f90'
1496  stop
1497  ! CALL F_EOS_rn
1498  END IF
1499 
1500  fden_id = sum( rhoi(1:ncomp) * ( log( rhoi(1:ncomp) ) - 1.0 ) )
1501 
1502  fden = fres * rhot + fden_id
1503 
1504 ELSE
1505  write (*,*) ' SUBROUTINE FDEN_CALC not available for cubic EOS'
1506  stop
1507 END IF
1508 
1509 END SUBROUTINE fden_calc
1510 
1511 
1512 
1513 
1514 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1515 ! SUBROUTINE polymer_free
1516 !
1517 ! This subroutine performes a phase equilibrium calculation assuming
1518 ! the polymer-lean hase to be polymer-free (x_poly=0). Only the
1519 ! equality of the solvent-fugacities has to be ensured (only one
1520 ! equation to be iterated). This procedure delivers very good
1521 ! appoximations for the polymer-rich phase up-to fairly close to the
1522 ! mixture critical point. Both, liquid-liquid and vapor-liquid
1523 ! equilibria can be calculated.
1524 ! See also comments to SUBROUTINE POLY_STA_VAR.
1525 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1526 !
1527  SUBROUTINE polymer_free (p_spec,sol,solution)
1528 !
1529  USE basic_variables
1530  IMPLICIT NONE
1531 !
1532 ! ----------------------------------------------------------------------
1533  REAL, INTENT(IN OUT) :: p_spec
1534  INTEGER, INTENT(OUT) :: sol
1535  REAL, INTENT(OUT) :: solution(10,4+nc*np)
1536 !
1537 ! ----------------------------------------------------------------------
1538  INTEGER :: k,j,ph, converg
1539  REAL :: grid(10)
1540 ! ----------------------------------------------------------------------
1541 
1542  sol = 0
1543 
1544  grid(1)=0.98
1545  grid(2)=0.9
1546  grid(3)=0.7
1547  grid(4)=0.5
1548  grid(5)=0.3
1549  grid(6)=0.2
1550  grid(7)=0.1
1551  grid(8)=0.05
1552 
1553  DO WHILE ( sol == 0 )
1554 
1555  DO j = 1,8
1556  ! Phase 2 is solvent-phase
1557  ! starting value for xi(1,1) of polymer-phase 1: w_polymer=0.95 to 0.05
1558  ! from simple approximate equation
1559  xi(1,1) = grid(j) / ( (1.0-grid(j)) * mm(1) / mm(2) ) !xi(1,1) Phase 1 Komponente 1
1560  IF ( mm(1) < 5000.0 ) xi(1,1) = xi(1,1) * 0.8
1561  xi(1,2) = 1.0 - xi(1,1) !xi(1,2) Phase 1 Komponente 2
1562  lnx(1,1) = log(xi(1,1))
1563  lnx(1,2) = log(xi(1,2))
1564  lnx(2,1) = -1.e10 !ln(xi) Phase 2 Komponente 1
1565  lnx(2,2) = 0.0 !ln(xi) Phase 2 Komponente 2
1566 
1567 
1568 
1569  val_init(1) = 0.45 ! starting density targeting at a liquid phase
1570  val_init(2) = 0.0001 ! starting density targeting at a vapor phase
1571  ! val_init(2) = 0.45
1572  val_init(3) = t
1573  val_init(4) = p
1574  DO ph = 1,nphas
1575  DO k = 1,ncomp
1576  val_init(4+k+(ph-1)*ncomp) = lnx(ph,k)
1577  END DO
1578  END DO
1579 
1580 
1581 
1582 
1583  n_unkw = ncomp-1 ! number of quantities to be iterated
1584  it(1) = 'x11' ! iteration of mol fraction of comp.1 phase 1
1585  it(2) = ' '
1586  sum_rel(1) = 'x12' ! summation relation: x12 = 1 - sum(x1j)
1587  sum_rel(2) = 'x22'
1588 
1589  CALL objective_ctrl (converg)
1590 
1591  IF (converg == 1 .AND. abs(dense(1)/dense(2)-1.0) > 1.d-3 .AND. dense(1) > 0.1) THEN
1592  IF (sol == 0) THEN
1593  sol = sol + 1
1594  DO k = 1,4+ncomp*nphas
1595  solution(sol,k) = val_conv(k)
1596  END DO
1597  ELSE IF (abs(solution(sol,5)/lnx(1,1)-1.0) > 1.d-2) THEN
1598  sol = sol + 1
1599  DO k = 1,4+ncomp*nphas
1600  solution(sol,k) = val_conv(k)
1601  END DO
1602  END IF
1603  END IF
1604 
1605  END DO
1606 
1607 
1608 
1609 
1610 
1611  IF (sol == 0) THEN
1612  WRITE (*,*) ' no initial solution found'
1613  p = p*0.9
1614  IF (p < (0.7*p_spec)) WRITE (*,*) ' NO SOLUTION FOUND'
1615  IF (p < (0.7*p_spec)) stop
1616  ELSE IF (sol > 1) THEN
1617  ! write (*,*) ' '
1618  ! write (*,*) ' ',sol,' solutions found:'
1619  ! write (*,*) ' lnx(1,1), dichte_1, dichte_2'
1620  ! DO k = 1,sol
1621  ! write (*,*) solution(k,5),solution(k,1),solution(k,2)
1622  ! END DO
1623  END IF
1624  END DO
1625 
1626  n_unkw = ncomp ! number of quantities to be iterated
1627  it(1) = 'x11' ! iteration of mol fraction of comp.1 phase 1
1628  it(2) = 'x21' ! iteration of mol fraction of comp.1 phase 2
1629  sum_rel(1) = 'x12' ! summation relation: x12 = 1 - sum(x1j)
1630  sum_rel(2) = 'x22' ! summation relation: x22 = 1 - sum(x2j)
1631 
1632 
1633  END SUBROUTINE polymer_free
1634 
1635 
1636 
1637 
1638 
1670  SUBROUTINE phase_equilib (end_x,steps,converg)
1671 !
1672  USE basic_variables
1673  IMPLICIT NONE
1674 !
1675 ! ----------------------------------------------------------------------
1676  REAL, INTENT(IN) :: end_x
1677  REAL, INTENT(IN) :: steps
1678  INTEGER, INTENT(OUT) :: converg
1679 !
1680 ! ----------------------------------------------------------------------
1681  INTEGER :: k, count1,count2,runindex,maxiter
1682  REAL :: delta_x,delta_org,val_org,runvar
1683  CHARACTER (LEN=2) :: compon
1684  LOGICAL :: continue_cycle
1685 ! ----------------------------------------------------------------------
1686 
1687 IF (running(1:2) == 'd1') runindex = 1
1688 IF (running(1:2) == 'd2') runindex = 2
1689 IF (running(1:1) == 't') runindex = 3
1690 IF (running(1:1) == 'p') runindex = 4
1691 IF (running(1:2) == 'x1') compon = running(3:3)
1692 IF (running(1:2) == 'x1') READ(compon,*) k
1693 IF (running(1:2) == 'x1') runindex = 4+k
1694 IF (running(1:2) == 'x2') compon = running(3:3)
1695 IF (running(1:2) == 'x2') READ(compon,*) k
1696 IF (running(1:2) == 'x2') runindex = 4+ncomp+k
1697 IF (running(1:2) == 'l1') compon = running(3:3)
1698 IF (running(1:2) == 'l1') READ(compon,*) k
1699 IF (running(1:2) == 'l1') runindex = 4+k
1700 IF (running(1:2) == 'l2') compon = running(3:3)
1701 IF (running(1:2) == 'l2') READ(compon,*) k
1702 IF (running(1:2) == 'l2') runindex = 4+ncomp+k
1703 
1704 maxiter = 200
1705 IF ( ncomp >= 3 ) maxiter = 1000
1706 count1 = 0
1707 count2 = 0
1708 delta_x = ( end_x - val_init(runindex) ) / steps !J: calc increment in running var = (phi_end - phi_init)/steps
1709 delta_org = ( end_x - val_init(runindex) ) / steps
1710 val_org = val_init(runindex)
1711 IF ( running(1:1) == 'x' ) THEN
1712  delta_x = ( end_x - exp(val_init(runindex)) ) / steps
1713  delta_org = ( end_x - exp(val_init(runindex)) ) / steps
1714  val_org = exp(val_init(runindex))
1715 END IF
1716 
1717 continue_cycle = .true.
1718 
1719 DO WHILE ( continue_cycle )
1720 
1721  count1 = count1 + 1
1722  count2 = count2 + 1
1723  ! val_org = val_init(runindex)
1724 
1725 
1726  CALL objective_ctrl (converg)
1727 
1728  IF (converg == 1) THEN
1729  val_init( 1:(4+ncomp*nphas) ) = val_conv( 1:(4+ncomp*nphas) )
1730  IF (outp == 1 .AND. (abs(delta_x) > 0.1*abs(delta_org) .OR. count2 == 2)) CALL output
1731  ELSE
1732  delta_x = delta_x / 2.0
1733  IF (num == 2) delta_x = delta_x / 2.0
1734  val_init(runindex) = val_org
1735  IF (running(1:1) == 'x') val_init(runindex) = log(val_org)
1736  continue_cycle = .true.
1737  count2 = 0
1738  END IF
1739  runvar = val_init(runindex)
1740  IF (running(1:1) == 'x') runvar = exp(val_init(runindex))
1741 
1742  IF ( end_x == 0.0 .AND. running(1:1) /= 'x' ) THEN
1743  IF ( abs(runvar-end_x) < 1.e-8 ) continue_cycle = .false.
1744  ELSE IF ( abs((runvar-end_x)/end_x) < 1.e-8 ) THEN
1745  ! IF(delta_org.NE.0.0) WRITE (*,*)' FINISHED ITERATION',count1
1746  continue_cycle = .false.
1747  ELSE IF ( count1 == maxiter ) THEN
1748  WRITE (*,*) ' MAX. NO OF ITERATIONS',count1
1749  converg = 0
1750  continue_cycle = .false.
1751  ELSE IF ( abs(delta_x) < 1.e-5*abs(delta_org) ) THEN
1752  ! WRITE (*,*) ' CLOSEST APPROACH REACHED',count1
1753  converg = 0
1754  continue_cycle = .false.
1755  ELSE
1756  continue_cycle = .true.
1757  val_org = runvar
1758  IF (abs(runvar+delta_x-end_x) > abs(runvar-end_x)) delta_x = end_x - runvar ! if end-point passed
1759  val_init(runindex) = runvar + delta_x
1760  IF (running(1:1) == 'x') val_init(runindex) = log(runvar+delta_x)
1761  END IF
1762 
1763  IF (abs(delta_x) < abs(delta_org) .AND. count2 >= 5) THEN
1764  delta_x = delta_x * 2.0
1765  count2 = 0
1766  END IF
1767 
1768 END DO ! continue_cycle
1769 
1770 END SUBROUTINE phase_equilib
1771 
1772 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1773 !
1774 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
1775 !
1776  SUBROUTINE new_flash (ph_it)
1777 !
1778  USE basic_variables
1779  IMPLICIT NONE
1780 !
1781 ! ----------------------------------------------------------------------
1782  INTEGER, INTENT(IN) :: ph_it
1783 !
1784 ! ----------------------------------------------------------------------
1785  INTEGER :: i, ph_cal
1786  REAL, DIMENSION(nc) :: ni_1, ni_2
1787 ! ----------------------------------------------------------------------
1788 
1789  ph_cal = 3 - ph_it ! for two phases only
1790 
1791  DO i = 1, ncomp
1792  IF ( lnx(ph_it,i) < -300.0 ) THEN
1793  ni_2(i) = 0.0
1794  ELSE
1795  ni_2(i) = exp( lnx(ph_it,i) )
1796  END IF
1797  END DO
1798 
1799  DO i = 1, ncomp
1800  ni_1(i) = xif(i)-ni_2(i)
1801  IF ( ni_2(i) > xif(i) ) THEN
1802  ni_2(i) = xif(i)
1803  ni_1(i) = xif(i) * 1.e-20
1804  ENDIF
1805  END DO
1806 
1807  xi(ph_it,1:ncomp) = ni_2(1:ncomp) / sum( ni_2(1:ncomp) )
1808  DO i = 1, ncomp
1809  IF ( xi(ph_it,i) >= 1.e-300 ) lnx(ph_it,i) = log( xi(ph_it,i) )
1810  END DO
1811  xi(ph_cal,1:ncomp) = ni_1(1:ncomp) / sum( ni_1(1:ncomp) )
1812  lnx(ph_cal,1:ncomp) = log( xi(ph_cal,1:ncomp) )
1813 
1814 END SUBROUTINE new_flash
1815 
1816 
1832  SUBROUTINE phi_eos
1833 !
1834  USE parameters
1835  USE eos_variables
1836  USE eos_constants
1837  IMPLICIT NONE
1838 !
1839 ! --- local variables---------------------------------------------------
1840  INTEGER :: i, j, k, ki, l, m
1841  REAL :: z0, z1, z2, z3, z0_rk, z1_rk, z2_rk, z3_rk
1842  REAL :: zms, m_mean
1843  REAL, DIMENSION(nc) :: mhs, mdsp, mhc, myres
1844  REAL, DIMENSION(nc) :: m_rk
1845  REAL :: gij_rk(nc,nc)
1846  REAL :: zres, zges
1847  REAL :: dpdz, dpdz2
1848 
1849  REAL :: i1, i2, i1_rk, i2_rk
1850  REAL :: ord1_rk, ord2_rk
1851  REAL :: c1_con, c2_con, c1_rk
1852  REAL :: zmr, nmr, zmr_rk, nmr_rk, um_rk
1853  REAL, DIMENSION(nc,0:6) :: ap_rk, bp_rk
1854 
1855  LOGICAL :: assoc
1856  REAL :: ass_s2, m_hbon(nc)
1857 
1858  REAL :: fdd_rk, fqq_rk, fdq_rk
1859  REAL, DIMENSION(nc) :: my_dd, my_qq, my_dq
1860 ! ----------------------------------------------------------------------
1861 
1862 ! ----------------------------------------------------------------------
1863 ! obtain parameters and density independent expressions
1864 ! ----------------------------------------------------------------------
1865 CALL perturbation_parameter
1866 
1867 
1868 ! ----------------------------------------------------------------------
1869 ! density iteration: (pTx)-ensemble OR p calc.: (pvx)-ensemble
1870 ! ----------------------------------------------------------------------
1871 IF (ensemble_flag == 'tp') THEN
1872  CALL density_iteration
1873 ELSEIF (ensemble_flag == 'tv') THEN
1874  eta = eta_start
1875  CALL p_eos
1876 ELSE
1877  write (*,*) 'PHI_EOS: define ensemble, ensemble_flag == (pv) or (pt)'
1878  stop
1879 END IF
1880 
1881 
1882 ! --- Eq.(A.8) ---------------------------------------------------------
1883 rho = eta / z3t
1884 z0 = z0t * rho
1885 z1 = z1t * rho
1886 z2 = z2t * rho
1887 z3 = z3t * rho
1888 
1889 m_mean = z0t / (pi/6.0)
1890 zms = 1.0 - eta
1891 
1892 ! ----------------------------------------------------------------------
1893 ! compressibility factor z = p/(kT*rho)
1894 ! ----------------------------------------------------------------------
1895 zges = (p * 1.d-30) / (kbol*t*rho)
1896 IF ( ensemble_flag == 'tv' ) zges = (pges * 1.d-30) / (kbol*t*rho)
1897 zres = zges - 1.0
1898 
1899 
1900 
1901 ! ======================================================================
1902 ! calculate the derivatives of f to mole fraction x ( d(f)/d(x) )
1903 ! ======================================================================
1904 
1905 DO k = 1, ncomp
1906 
1907  z0_rk = pi/6.0 * mseg(k)
1908  z1_rk = pi/6.0 * mseg(k) * dhs(k)
1909  z2_rk = pi/6.0 * mseg(k) * dhs(k)*dhs(k)
1910  z3_rk = pi/6.0 * mseg(k) * dhs(k)**3
1911 
1912 ! --- derivative d(m_mean)/d(x) ----------------------------------------
1913  m_rk(k) = ( mseg(k) - m_mean ) / rho
1914  ! lij(1,2)= -0.050
1915  ! lij(2,1)=lij(1,2)
1916  ! r_m2dx(k)=0.0
1917  ! m_mean2=0.0
1918  ! DO i =1,ncomp
1919  ! r_m2dx(k)=r_m2dx(k)+2.0*x(i)*(mseg(i)+mseg(k))/2.0*(1.0-lij(i,k))
1920  ! DO j =1,ncomp
1921  ! m_mean2=m_mean2+x(i)*x(j)*(mseg(i)+mseg(j))/2.0*(1.0-lij(i,j))
1922  ! ENDDO
1923  ! ENDDO
1924 
1925  ! --------------------------------------------------------------------
1926  ! d(f)/d(x) : hard sphere contribution
1927  ! --------------------------------------------------------------------
1928  mhs(k) = 6.0/pi* ( 3.0*(z1_rk*z2+z1*z2_rk)/zms + 3.0*z1*z2*z3_rk/zms/zms &
1929  + 3.0*z2*z2*z2_rk/z3/zms/zms + z2**3 *z3_rk*(3.0*z3-1.0)/z3/z3/zms**3 &
1930  + ((3.0*z2*z2*z2_rk*z3-2.0*z2**3 *z3_rk)/z3**3 -z0_rk) *log(zms) &
1931  + (z0-z2**3 /z3/z3)*z3_rk/zms )
1932 
1933  ! --------------------------------------------------------------------
1934  ! d(f)/d(x) : chain term
1935  ! --------------------------------------------------------------------
1936  DO i = 1, ncomp
1937  DO j = 1, ncomp
1938  gij(i,j) = 1.0/zms + 3.0*dij_ab(i,j)*z2/zms/zms + 2.0*(dij_ab(i,j)*z2)**2 /zms**3
1939  gij_rk(i,j) = z3_rk/zms/zms &
1940  + 3.0*dij_ab(i,j)*(z2_rk+2.0*z2*z3_rk/zms)/zms/zms &
1941  + dij_ab(i,j)**2 *z2/zms**3 *(4.0*z2_rk+6.0*z2*z3_rk/zms)
1942  END DO
1943  END DO
1944 
1945  mhc(k) = 0.0
1946  DO i = 1, ncomp
1947  mhc(k) = mhc(k) + x(i)*rho * (1.0-mseg(i)) / gij(i,i) * gij_rk(i,i)
1948  END DO
1949  mhc(k) = mhc(k) + ( 1.0-mseg(k)) * log( gij(k,k) )
1950 
1951 
1952  ! --------------------------------------------------------------------
1953  ! PC-SAFT: d(f)/d(x) : dispersion contribution
1954  ! --------------------------------------------------------------------
1955  IF (eos == 1) THEN
1956 
1957  ! --- derivatives of apar, bpar to rho_k ---------------------------
1958  DO m = 0, 6
1959  ap_rk(k,m) = m_rk(k)/m_mean**2 * ( ap(m,2) + (3.0 -4.0/m_mean) *ap(m,3) )
1960  bp_rk(k,m) = m_rk(k)/m_mean**2 * ( bp(m,2) + (3.0 -4.0/m_mean) *bp(m,3) )
1961  END DO
1962 
1963  i1 = 0.0
1964  i2 = 0.0
1965  i1_rk = 0.0
1966  i2_rk = 0.0
1967  DO m = 0, 6
1968  i1 = i1 + apar(m)*eta**REAL(m)
1969  i2 = i2 + bpar(m)*eta**REAL(m)
1970  i1_rk = i1_rk + apar(m)*REAL(m)*eta**REAL(m-1)*z3_rk + ap_rk(k,m)*eta**REAL(m)
1971  i2_rk = i2_rk + bpar(m)*REAL(m)*eta**REAL(m-1)*z3_rk + bp_rk(k,m)*eta**REAL(m)
1972  END DO
1973 
1974  ord1_rk = 0.0
1975  ord2_rk = 0.0
1976  DO i = 1,ncomp
1977  ord1_rk = ord1_rk + 2.0*mseg(k)*rho*x(i)*mseg(i)*sig_ij(i,k)**3 *uij(i,k)/t
1978  ord2_rk = ord2_rk + 2.0*mseg(k)*rho*x(i)*mseg(i)*sig_ij(i,k)**3 *(uij(i,k)/t)**2
1979  END DO
1980 
1981  c1_con= 1.0/ ( 1.0 + m_mean*(8.0*z3-2.0*z3*z3)/zms**4 &
1982  + (1.0 - m_mean)*(20.0*z3-27.0*z3*z3 +12.0*z3**3 -2.0*z3**4 ) &
1983  /(zms*(2.0-z3))**2 )
1984  c2_con= - c1_con*c1_con *( m_mean*(-4.0*z3*z3+20.0*z3+8.0)/zms**5 &
1985  + (1.0 - m_mean) *(2.0*z3**3 +12.0*z3*z3-48.0*z3+40.0) &
1986  /(zms*(2.0-z3))**3 )
1987  c1_rk= c2_con*z3_rk - c1_con*c1_con*m_rk(k) * ( (8.0*z3-2.0*z3*z3)/zms**4 &
1988  - (-2.0*z3**4 +12.0*z3**3 -27.0*z3*z3+20.0*z3) / (zms*(2.0-z3))**2 )
1989 
1990  mdsp(k) = -2.0*pi* ( order1*rho*rho*i1_rk + ord1_rk*i1 ) &
1991  - pi* c1_con*m_mean * ( order2*rho*rho*i2_rk + ord2_rk*i2 ) &
1992  - pi* ( c1_con*m_rk(k) + c1_rk*m_mean ) * order2*rho*rho*i2
1993 
1994  ! --------------------------------------------------------------------
1995  ! SAFT: d(f)/d(x) : dispersion contribution
1996  ! --------------------------------------------------------------------
1997  ELSE
1998 
1999  zmr = 0.0
2000  nmr = 0.0
2001  zmr_rk = 0.0
2002  nmr_rk = 0.0
2003  DO i = 1, ncomp
2004  DO j = 1, ncomp
2005  zmr = zmr + x(i)*x(j)*mseg(i)*mseg(j)*vij(i,j)*uij(i,j)
2006  nmr = nmr + x(i)*x(j)*mseg(i)*mseg(j)*vij(i,j)
2007  END DO
2008  zmr_rk = zmr_rk + 2.0*mseg(k) * x(i)*mseg(i)*vij(k,i)*uij(k,i)
2009  nmr_rk = nmr_rk + 2.0*mseg(k) * x(i)*mseg(i)*vij(k,i)
2010  END DO
2011 
2012  um_rk = 1.0/nmr**2 * ( nmr*zmr_rk - zmr*nmr_rk )
2013 
2014  mdsp(k) = 0.0
2015  DO i = 1,4
2016  DO j = 1,9
2017  mdsp(k) = mdsp(k) + dnm(i,j)*(um/t)**REAL(i)*(eta/tau)**REAL(j) &
2018  * ( 1.0 + z3_rk*rho/eta*REAL(j) + um_rk*rho/um*REAL(i) )
2019  END DO
2020  END DO
2021 
2022  END IF
2023  ! --- end of dispersion contribution------------------------------------
2024 
2025 
2026  ! --------------------------------------------------------------------
2027  ! TPT-1-association according to Chapman et al.
2028  ! --------------------------------------------------------------------
2029  m_hbon(k) = 0.0
2030  assoc = .false.
2031  DO i = 1,ncomp
2032  IF (nhb_typ(i) /= 0) assoc = .true.
2033  END DO
2034  IF (assoc) THEN
2035 
2036  ass_s2 = 0.0
2037  DO l = 1, nhb_typ(k)
2038  ass_s2 = ass_s2 + nhb_no(k,l) * log(mx(k,l))
2039  END DO
2040 
2041  m_hbon(k)=ass_s2
2042  DO i = 1, ncomp
2043  DO ki = 1, nhb_typ(i)
2044  DO j = 1, ncomp
2045  DO l = 1, nhb_typ(j)
2046  m_hbon(k)= m_hbon(k) - rho*rho/2.0*x(i)*x(j) *mx(i,ki)*mx(j,l) *nhb_no(i,ki)*nhb_no(j,l) &
2047  * gij_rk(i,j) * ass_d(i,j,ki,l)
2048  END DO
2049  END DO
2050  END DO
2051  END DO
2052 
2053  END IF
2054  ! --- end of TPT-1-association accord. to Chapman --------------------
2055 
2056 
2057  ! --------------------------------------------------------------------
2058  ! polar terms
2059  ! --------------------------------------------------------------------
2060  CALL phi_polar ( k, z3_rk, fdd_rk, fqq_rk, fdq_rk )
2061  my_dd(k) = fdd_rk
2062  my_qq(k) = fqq_rk
2063  my_dq(k) = fdq_rk
2064 
2065 
2066  ! --------------------------------------------------------------------
2067  ! d(f)/d(x) : summation of all contributions
2068  ! --------------------------------------------------------------------
2069  myres(k) = mhs(k) +mhc(k) +mdsp(k) +m_hbon(k) +my_dd(k) +my_qq(k) +my_dq(k)
2070 
2071 END DO
2072 
2073 
2074 ! ----------------------------------------------------------------------
2075 ! finally calculate
2076 ! mu_i^res(T,p,x)/kT = ln( phi_i ) when ensemble_flag = 'tp'
2077 ! mu_i^res(T,rho,x)/kT when ensemble_flag = 'tv'
2078 ! ----------------------------------------------------------------------
2079 
2080 DO k = 1, ncomp
2081  ! write (*,*) k,myres(k) +LOG(rho*x(k)),rho
2082  IF (ensemble_flag == 'tp' ) lnphi(k) = myres(k) - log(zges)
2083  IF (ensemble_flag == 'tv' ) lnphi(k) = myres(k)
2084  ! write (*,*) 'in',k,EXP(lnphi(k)),LOG(zges),eta
2085 END DO
2086 !write (*,'(5G18.10)') lnphi(1),rho
2087 
2088 dpdz = pgesdz
2089 dpdz2 = pgesd2
2090 
2091 END SUBROUTINE phi_eos
2092 
2093 
2094 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
2095 !
2096 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
2097 !
2098  SUBROUTINE phi_numerical
2099 !
2100  USE eos_variables
2101  USE eos_constants
2102  USE dft_module, ONLY: z_ges, fres_temp
2103  IMPLICIT NONE
2104 !
2105 !-----local variables-------------------------------------------------
2106  INTEGER :: k
2107  REAL :: zres, zges
2108  REAL :: fres1, fres2, fres3, fres4, fres5
2109  REAL :: delta_rho
2110  REAL, DIMENSION(nc) :: myres
2111  REAL, DIMENSION(nc) :: rhoi, rhoi_0
2112  REAL :: tfr_1, tfr_2, tfr_3, tfr_4, tfr_5
2113 !-----------------------------------------------------------------------
2114 
2115 
2116 !-----------------------------------------------------------------------
2117 ! density iteration or pressure calculation
2118 !-----------------------------------------------------------------------
2119 
2120 IF (ensemble_flag == 'tp') THEN
2121  CALL density_iteration
2122 ELSEIF (ensemble_flag == 'tv') THEN
2123  eta = eta_start
2124  CALL p_numerical
2125 ELSE
2126  write (*,*) 'PHI_EOS: define ensemble, ensemble_flag == (tv) or (tp)'
2127  stop
2128 END IF
2129 
2130 !-----------------------------------------------------------------------
2131 ! compressibility factor z = p/(kT*rho)
2132 !-----------------------------------------------------------------------
2133 
2134 zges = (p * 1.e-30) / (kbol*t*eta/z3t)
2135 IF ( ensemble_flag == 'tv' ) zges = (pges * 1.e-30) / (kbol*t*eta/z3t)
2136 zres = zges - 1.0
2137 z_ges = zges
2138 
2139 rhoi_0(1:ncomp) = x(1:ncomp) * eta/z3t
2140 rhoi(1:ncomp) = rhoi_0(1:ncomp)
2141 
2142 
2143 !-----------------------------------------------------------------------
2144 ! derivative to rho_k (keeping other rho_i's constant
2145 !-----------------------------------------------------------------------
2146 
2147 DO k = 1, ncomp
2148 
2149  IF ( rhoi_0(k) > 1.d-9 ) THEN
2150  delta_rho = 1.e-13 * 10.0**(0.5*(15.0+log10(rhoi_0(k))))
2151  ELSE
2152  delta_rho = 1.e-10
2153  END IF
2154 
2155  rhoi(k) = rhoi_0(k) + delta_rho
2156  eta = pi/6.0 * sum( rhoi(1:ncomp)*mseg(1:ncomp)*dhs(1:ncomp)**3 )
2157  x(1:ncomp) = rhoi(1:ncomp) / sum( rhoi(1:ncomp) )
2158  rho = sum( rhoi(1:ncomp) )
2159  CALL f_numerical
2160  fres1 = fres*rho
2161  tfr_1 = tfr*rho
2162 
2163  rhoi(k) = rhoi_0(k) + 0.5 * delta_rho
2164  eta = pi/6.0 * sum( rhoi(1:ncomp)*mseg(1:ncomp)*dhs(1:ncomp)**3 )
2165  x(1:ncomp) = rhoi(1:ncomp) / sum( rhoi(1:ncomp) )
2166  rho = sum( rhoi(1:ncomp) )
2167  CALL f_numerical
2168  fres2 = fres*rho
2169  tfr_2 = tfr*rho
2170 
2171  IF ( rhoi_0(k) > 1.e-9 ) THEN
2172  rhoi(k) = rhoi_0(k) - 0.5 * delta_rho
2173  eta = pi/6.0 * sum( rhoi(1:ncomp)*mseg(1:ncomp)*dhs(1:ncomp)**3 )
2174  x(1:ncomp) = rhoi(1:ncomp) / sum( rhoi(1:ncomp) )
2175  rho = sum( rhoi(1:ncomp) )
2176  CALL f_numerical
2177  fres4 = fres*rho
2178  tfr_4 = tfr*rho
2179 
2180  rhoi(k) = rhoi_0(k) - delta_rho
2181  eta = pi/6.0 * sum( rhoi(1:ncomp)*mseg(1:ncomp)*dhs(1:ncomp)**3 )
2182  x(1:ncomp) = rhoi(1:ncomp) / sum( rhoi(1:ncomp) )
2183  rho = sum( rhoi(1:ncomp) )
2184  CALL f_numerical
2185  fres5 = fres*rho
2186  tfr_5 = tfr*rho
2187  END IF
2188 
2189  rhoi(k) = rhoi_0(k)
2190  eta = pi/6.0 * sum( rhoi(1:ncomp)*mseg(1:ncomp)*dhs(1:ncomp)**3 )
2191  x(1:ncomp) = rhoi(1:ncomp) / sum( rhoi(1:ncomp) )
2192  rho = sum( rhoi(1:ncomp) )
2193  CALL f_numerical
2194  fres3 = fres*rho
2195  tfr_3 = tfr*rho
2196 
2197  IF ( rhoi_0(k) > 1.e-9 ) THEN
2198  myres(k) = ( fres5 - 8.0*fres4 + 8.0*fres2 - fres1 ) / ( 6.0*delta_rho )
2199  ELSE
2200  myres(k) = ( -3.0*fres3 + 4.0*fres2 - fres1 ) / delta_rho
2201  END IF
2202 
2203 END DO
2204 
2205 
2206 !-----------------------------------------------------------------------
2207 ! residual Helmholtz energy
2208 !-----------------------------------------------------------------------
2209 
2210 fres_temp = fres
2211 
2212 !-----------------------------------------------------------------------
2213 ! residual chemical potential
2214 !-----------------------------------------------------------------------
2215 
2216 DO k = 1, ncomp
2217  IF (ensemble_flag == 'tp') lnphi(k) = myres(k) - log(zges)
2218  IF (ensemble_flag == 'tv' .AND. eta >= 0.0) lnphi(k) = myres(k) !+LOG(rho)
2219  ! write (*,*) 'in',k,EXP(lnphi(k)),LOG(zges),eta
2220  ! IF (DFT.GE.98) write (*,*) dft
2221  ! write (*,*) 'lnphi',k,LNPHI(k),x(k),MYRES(k), -LOG(ZGES)
2222  ! pause
2223  ! write (*,*) k, myres(k), fres, ZRES
2224 END DO
2225 
2226 END SUBROUTINE phi_numerical
2227 
2228 
2229 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
2230 !
2231 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
2232 
2233 ! SUBROUTINE H_EOS (phas,h_res,s_res,cp_res,X,T,P,PARAME,
2234 ! 1 KIJ,lij,NCOMP,ETA_START,ETA,eos,tfr)
2235 ! IMPLICIT NONE
2236 ! INTEGER nc
2237 ! PARAMETER (nc=20)
2238 ! INTEGER phas,ncomp,eos,i
2239 ! REAL kij(nc,nc),lij(nc,nc),x(nc),t,p,parame(nc,25)
2240 ! REAL eta_start,eta,tfr,h_res,cp_res,s_res
2241 
2242 
2243 ! i=1
2244 
2245 ! IF (i.EQ.1) THEN
2246 ! CALL H_EOS_1(phas,h_res,s_res,cp_res,X,T,P,PARAME,
2247 ! 1 KIJ,lij,NCOMP,ETA_START,ETA,eos,tfr)
2248 ! ELSE
2249 ! CALL H_EOS_NUM (phas,h_res,s_res,cp_res,X,T,P,PARAME,
2250 ! 1 KIJ,lij,NCOMP,ETA_START,ETA,eos,tfr)
2251 ! ENDIF
2252 
2253 ! RETURN
2254 ! END
2255 
2256 
2257 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
2258 !
2259 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
2260 !
2261  SUBROUTINE h_eos
2262 !
2263  USE parameters, ONLY: rgas
2264  USE eos_constants
2265  USE eos_variables
2266  IMPLICIT NONE
2267 !
2268 ! ----------------------------------------------------------------------
2269  REAL :: zges, df_dt, dfdr, ddfdrdr
2270  REAL :: cv_res, df_dt2, df_drdt
2271  REAL :: fact, dist, t_tmp, rho_0
2272  REAL :: fdr1, fdr2, fdr3, fdr4
2273 
2274  INTEGER :: i, m
2275  REAL :: dhsdt(nc), dhsdt2(nc)
2276  REAL :: z0, z1, z2, z3, z1tdt, z2tdt, z3tdt
2277  REAL :: z1dt, z2dt, z3dt, zms, gii
2278  REAL :: fhsdt, fhsdt2
2279  REAL :: fchdt, fchdt2
2280  REAL :: fdspdt, fdspdt2
2281  REAL :: fhbdt, fhbdt2
2282  REAL :: sumseg, i1, i2, i1dt, i2dt, i1dt2, i2dt2
2283  REAL :: c1_con, c2_con, c3_con, c1_dt, c1_dt2
2284  REAL :: z1tdt2, z2tdt2, z3tdt2
2285  REAL :: z1dt2, z2dt2, z3dt2
2286 
2287  INTEGER :: j, k, l, no, ass_cnt, max_eval
2288  LOGICAL :: assoc
2289  REAL :: dij, dijdt, dijdt2
2290  REAL :: gij1dt, gij2dt, gij3dt
2291  REAL :: gij1dt2, gij2dt2, gij3dt2
2292  REAL, DIMENSION(nc,nc) :: gijdt, gijdt2, kap_hb
2293  REAL, DIMENSION(nc,nc,nsite,nsite) :: ass_d_dt, ass_d_dt2, eps_hb, delta, deltadt, deltadt2
2294  REAL, DIMENSION(nc,nsite) :: mxdt, mxdt2, mx_itr, mx_itrdt, mx_itrdt2
2295  REAL :: attenu, tol, suma, sumdt, sumdt2, err_sum
2296 
2297  INTEGER :: dipole
2298  REAL :: fdddt, fdddt2
2299  REAL, DIMENSION(nc) :: my2dd, my0
2300  REAL, DIMENSION(nc,nc) :: idd2, idd2dt, idd2dt2, idd4, idd4dt, idd4dt2
2301  REAL, DIMENSION(nc,nc,nc) :: idd3, idd3dt, idd3dt2
2302  REAL :: factor2, factor3
2303  REAL :: fdd2, fdd3, fdd2dt, fdd3dt, fdd2dt2, fdd3dt2
2304  REAL :: eij, xijmt, xijkmt
2305 
2306  INTEGER :: qudpole
2307  REAL :: fqqdt, fqqdt2
2308  REAL, DIMENSION(nc) :: qq2
2309  REAL, DIMENSION(nc,nc) :: iqq2, iqq2dt, iqq2dt2, iqq4, iqq4dt, iqq4dt2
2310  REAL, DIMENSION(nc,nc,nc) :: iqq3, iqq3dt, iqq3dt2
2311  REAL :: fqq2, fqq2dt, fqq2dt2, fqq3, fqq3dt, fqq3dt2
2312 
2313  INTEGER :: dip_quad
2314  REAL :: fdqdt, fdqdt2
2315  REAL, DIMENSION(nc) :: myfac, q_fac
2316  REAL, DIMENSION(nc,nc) :: idq2, idq2dt, idq2dt2, idq4, idq4dt, idq4dt2
2317  REAL, DIMENSION(nc,nc,nc) :: idq3, idq3dt, idq3dt2
2318  REAL :: fdq2, fdq2dt, fdq2dt2, fdq3, fdq3dt, fdq3dt2
2319 ! ----------------------------------------------------------------------
2320 
2321 
2322 ! ----------------------------------------------------------------------
2323 ! Initializing
2324 ! ----------------------------------------------------------------------
2325 CALL perturbation_parameter
2326 
2327 rho = eta/z3t
2328 z0 = z0t*rho
2329 z1 = z1t*rho
2330 z2 = z2t*rho
2331 z3 = z3t*rho
2332 
2333 sumseg = z0t / (pi/6.0)
2334 zms = 1.0 - z3
2335 
2336 
2337 ! ----------------------------------------------------------------------
2338 ! first and second derivative of f to density (dfdr,ddfdrdr)
2339 ! ----------------------------------------------------------------------
2340 CALL p_eos
2341 
2342 zges = (pges * 1.e-30)/(kbol*t*rho)
2343 
2344 dfdr = pges/(eta*rho*(kbol*t)/1.e-30)
2345 ddfdrdr = pgesdz/(eta*rho*(kbol*t)/1.e-30) - dfdr*2.0/eta - 1.0/eta**2
2346 
2347 
2348 ! ----------------------------------------------------------------------
2349 ! Helmholtz Energy f/kT = fres
2350 ! ----------------------------------------------------------------------
2351 CALL f_eos
2352 
2353 
2354 ! ----------------------------------------------------------------------
2355 ! derivative of some auxilliary properties to temperature
2356 ! ----------------------------------------------------------------------
2357 DO i = 1,ncomp
2358  dhsdt(i)=parame(i,2) *(-3.0*parame(i,3)/t/t)*0.12*exp(-3.0*parame(i,3)/t)
2359  dhsdt2(i) = dhsdt(i)*3.0*parame(i,3)/t/t &
2360  + 6.0*parame(i,2)*parame(i,3)/t**3 *0.12*exp(-3.0*parame(i,3)/t)
2361 END DO
2362 
2363 z1tdt = 0.0
2364 z2tdt = 0.0
2365 z3tdt = 0.0
2366 DO i = 1,ncomp
2367  z1tdt = z1tdt + x(i) * mseg(i) * dhsdt(i)
2368  z2tdt = z2tdt + x(i) * mseg(i) * 2.0*dhs(i)*dhsdt(i)
2369  z3tdt = z3tdt + x(i) * mseg(i) * 3.0*dhs(i)*dhs(i)*dhsdt(i)
2370 END DO
2371 z1dt = pi / 6.0*z1tdt *rho
2372 z2dt = pi / 6.0*z2tdt *rho
2373 z3dt = pi / 6.0*z3tdt *rho
2374 
2375 
2376 z1tdt2 = 0.0
2377 z2tdt2 = 0.0
2378 z3tdt2 = 0.0
2379 DO i = 1,ncomp
2380  z1tdt2 = z1tdt2 + x(i)*mseg(i)*dhsdt2(i)
2381  z2tdt2 = z2tdt2 + x(i)*mseg(i)*2.0 *( dhsdt(i)*dhsdt(i) +dhs(i)*dhsdt2(i) )
2382  z3tdt2 = z3tdt2 + x(i)*mseg(i)*3.0 *( 2.0*dhs(i)*dhsdt(i)* &
2383  dhsdt(i) +dhs(i)*dhs(i)*dhsdt2(i) )
2384 END DO
2385 z1dt2 = pi / 6.0*z1tdt2 *rho
2386 z2dt2 = pi / 6.0*z2tdt2 *rho
2387 z3dt2 = pi / 6.0*z3tdt2 *rho
2388 
2389 
2390 ! ----------------------------------------------------------------------
2391 ! 1st & 2nd derivative of f/kT hard spheres to temp. (fhsdt)
2392 ! ----------------------------------------------------------------------
2393 fhsdt = 6.0/pi/rho*( 3.0*(z1dt*z2+z1*z2dt)/zms + 3.0*z1*z2*z3dt/zms/zms &
2394  + 3.0*z2*z2*z2dt/z3/zms/zms &
2395  + z2**3 *(2.0*z3*z3dt-z3dt*zms)/(z3*z3*zms**3 ) &
2396  + (3.0*z2*z2*z2dt*z3-2.0*z2**3 *z3dt)/z3**3 *log(zms) &
2397  + (z0-z2**3 /z3/z3)*z3dt/zms )
2398 
2399 fhsdt2= 6.0/pi/rho*( 3.0*(z1dt2*z2+2.0*z1dt*z2dt+z1*z2dt2)/zms &
2400  + 6.0*(z1dt*z2+z1*z2dt)*z3dt/zms/zms &
2401  + 3.0*z1*z2*z3dt2/zms/zms + 6.0*z1*z2*z3dt*z3dt/zms**3 &
2402  + 3.0*z2*(2.0*z2dt*z2dt+z2*z2dt2)/z3/zms/zms &
2403  - z2*z2*(6.0*z2dt*z3dt+z2*z3dt2)/(z3*z3*zms*zms) &
2404  + 2.0*z2**3 *z3dt*z3dt/(z3**3 *zms*zms) &
2405  - 4.0*z2**3 *z3dt*z3dt/(z3*z3 *zms**3 ) &
2406  + (12.0*z2*z2*z2dt*z3dt+2.0*z2**3 *z3dt2)/(z3*zms**3 ) &
2407  + 6.0*z2**3 *z3dt*z3dt/(z3*zms**4 ) &
2408  - 2.0*(3.0*z2*z2*z2dt/z3/z3-2.0*z2**3 *z3dt/z3**3 ) *z3dt/zms &
2409  -(z2**3 /z3/z3-z0)*(z3dt2/zms+z3dt*z3dt/zms/zms) &
2410  + ( (6.0*z2*z2dt*z2dt+3.0*z2*z2*z2dt2)/z3/z3 &
2411  - (12.0*z2*z2*z2dt*z3dt+2.0*z2**3 *z3dt2)/z3**3 &
2412  + 6.0*z2**3 *z3dt*z3dt/z3**4 )* log(zms) )
2413 
2414 
2415 ! ----------------------------------------------------------------------
2416 ! 1st & 2nd derivative of f/kT of chain term to T (fchdt)
2417 ! ----------------------------------------------------------------------
2418 fchdt = 0.0
2419 fchdt2 = 0.0
2420 DO i = 1, ncomp
2421  DO j = 1, ncomp
2422  dij=dhs(i)*dhs(j)/(dhs(i)+dhs(j))
2423  dijdt =(dhsdt(i)*dhs(j) + dhs(i)*dhsdt(j)) / (dhs(i)+dhs(j)) &
2424  - dhs(i)*dhs(j)/(dhs(i)+dhs(j))**2 *(dhsdt(i)+dhsdt(j))
2425  dijdt2=(dhsdt2(i)*dhs(j) + 2.0*dhsdt(i)*dhsdt(j) &
2426  + dhs(i)*dhsdt2(j)) / (dhs(i)+dhs(j)) &
2427  - 2.0*(dhsdt(i)*dhs(j) + dhs(i)*dhsdt(j)) &
2428  / (dhs(i)+dhs(j))**2 *(dhsdt(i)+dhsdt(j)) &
2429  + 2.0* dhs(i)*dhs(j) / (dhs(i)+dhs(j))**3 &
2430  * (dhsdt(i)+dhsdt(j))**2 &
2431  - dhs(i)*dhs(j)/(dhs(i)+dhs(j))**2 *(dhsdt2(i)+dhsdt2(j))
2432  gij1dt = z3dt/zms/zms
2433  gij2dt = 3.0*( z2dt*dij+z2*dijdt )/zms/zms +6.0*z2*dij*z3dt/zms**3
2434  gij3dt = 4.0*(dij*z2)* (dijdt*z2 + dij*z2dt) /zms**3 &
2435  + 6.0*(dij*z2)**2 * z3dt /zms**4
2436  gij1dt2 = z3dt2/zms/zms +2.0*z3dt*z3dt/zms**3
2437  gij2dt2 = 3.0*( z2dt2*dij+2.0*z2dt*dijdt+z2*dijdt2 )/zms/zms &
2438  + 6.0*( z2dt*dij+z2*dijdt )/zms**3 * z3dt &
2439  + 6.0*(z2dt*dij*z3dt+z2*dijdt*z3dt+z2*dij*z3dt2) /zms**3 &
2440  + 18.0*z2*dij*z3dt*z3dt/zms**4
2441  gij3dt2 = 4.0*(dijdt*z2+dij*z2dt)**2 /zms**3 &
2442  + 4.0*(dij*z2)* (dijdt2*z2+2.0*dijdt*z2dt+dij*z2dt2) /zms**3 &
2443  + 24.0*(dij*z2) *(dijdt*z2+dij*z2dt)/zms**4 *z3dt &
2444  + 6.0*(dij*z2)**2 * z3dt2 /zms**4 &
2445  + 24.0*(dij*z2)**2 * z3dt*z3dt /zms**5
2446  gijdt(i,j) = gij1dt + gij2dt + gij3dt
2447  gijdt2(i,j) = gij1dt2 + gij2dt2 + gij3dt2
2448  END DO
2449 END DO
2450 
2451 DO i = 1, ncomp
2452  gii = 1.0/zms + 3.0*dhs(i)/2.0*z2/zms/zms + 2.0*dhs(i)*dhs(i)/4.0*z2*z2/zms**3
2453  fchdt = fchdt + x(i) * (1.0-mseg(i)) * gijdt(i,i) / gii
2454  fchdt2= fchdt2+ x(i) * (1.0-mseg(i)) &
2455  * (gijdt2(i,i) / gii - (gijdt(i,i)/gii)**2 )
2456 END DO
2457 
2458 
2459 ! ----------------------------------------------------------------------
2460 ! 1st & 2nd derivative of f/kT dispersion term to T (fdspdt)
2461 ! ----------------------------------------------------------------------
2462 i1 = 0.0
2463 i2 = 0.0
2464 i1dt = 0.0
2465 i2dt = 0.0
2466 i1dt2= 0.0
2467 i2dt2= 0.0
2468 DO m = 0, 6
2469  i1 = i1 + apar(m)*z3**REAL(m)
2470  i2 = i2 + bpar(m)*z3**REAL(m)
2471  i1dt = i1dt + apar(m)*z3dt*REAL(m)*z3**REAL(m-1)
2472  i2dt = i2dt + bpar(m)*z3dt*REAL(m)*z3**REAL(m-1)
2473  i1dt2= i1dt2+ apar(m)*z3dt2*REAL(m)*z3**REAL(m-1) &
2474  + apar(m)*z3dt*z3dt *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2475  i2dt2= i2dt2+ bpar(m)*z3dt2*REAL(m)*z3**REAL(m-1) &
2476  + bpar(m)*z3dt*z3dt *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2477 END DO
2478 
2479 c1_con= 1.0/ ( 1.0 + sumseg*(8.0*z3-2.0*z3**2 )/zms**4 &
2480  + (1.0 - sumseg)*(20.0*z3-27.0*z3**2 +12.0*z3**3 -2.0*z3**4 ) &
2481  /(zms*(2.0-z3))**2 )
2482 c2_con= - c1_con*c1_con *(sumseg*(-4.0*z3**2 +20.0*z3+8.0)/zms**5 &
2483  + (1.0 - sumseg) *(2.0*z3**3 +12.0*z3**2 -48.0*z3+40.0) &
2484  /(zms*(2.0-z3))**3 )
2485 c3_con= 2.0 * c2_con*c2_con/c1_con - c1_con*c1_con &
2486  *( sumseg*(-12.0*z3**2 +72.0*z3+60.0)/zms**6 + (1.0 - sumseg) &
2487  *(-6.0*z3**4 -48.0*z3**3 +288.0*z3**2 -480.0*z3+264.0) &
2488  /(zms*(2.0-z3))**4 )
2489 c1_dt = c2_con*z3dt
2490 c1_dt2 = c3_con*z3dt*z3dt + c2_con*z3dt2
2491 
2492 fdspdt = - 2.0*pi*rho*(i1dt-i1/t)*order1 &
2493  - pi*rho*sumseg*(c1_dt*i2+c1_con*i2dt-2.0*c1_con*i2/t)*order2
2494 
2495 fdspdt2 = - 2.0*pi*rho*(i1dt2-2.0*i1dt/t+2.0*i1/t/t)*order1 &
2496  - pi*rho*sumseg*order2*( c1_dt2*i2 +2.0*c1_dt*i2dt -4.0*c1_dt*i2/t &
2497  + 6.0*c1_con*i2/t/t -4.0*c1_con*i2dt/t +c1_con*i2dt2)
2498 
2499 
2500 ! ----------------------------------------------------------------------
2501 ! 1st & 2nd derivative of f/kT association term to T (fhbdt)
2502 ! ----------------------------------------------------------------------
2503 fhbdt = 0.0
2504 fhbdt2 = 0.0
2505 assoc = .false.
2506 DO i = 1,ncomp
2507  IF ( nhb_typ(i) /= 0 ) assoc = .true.
2508 END DO
2509 IF (assoc) THEN
2510 
2511  DO i = 1,ncomp
2512  IF ( nhb_typ(i) /= 0 ) THEN
2513  kap_hb(i,i) = parame(i,13)
2514  no = 0
2515  DO j = 1,nhb_typ(i)
2516  DO k = 1,nhb_typ(i)
2517  eps_hb(i,i,j,k) = parame(i,(14+no))
2518  no = no + 1
2519  END DO
2520  END DO
2521  DO j = 1,nhb_typ(i)
2522  no = no + 1
2523  END DO
2524  ELSE
2525  kap_hb(i,i) = 0.0
2526  DO k = 1,nsite
2527  DO l = 1,nsite
2528  eps_hb(i,i,k,l) = 0.0
2529  END DO
2530  END DO
2531  END IF
2532  END DO
2533 
2534  DO i = 1,ncomp
2535  DO j = 1,ncomp
2536  IF ( i /= j .AND. (nhb_typ(i) /= 0 .AND. nhb_typ(j) /= 0) ) THEN
2537  kap_hb(i,j)= (kap_hb(i,i)*kap_hb(j,j))**0.5 &
2538  *((parame(i,2)*parame(j,2))**3 )**0.5 &
2539  /(0.5*(parame(i,2)+parame(j,2)))**3
2540  ! kap_hb(i,j)= kap_hb(i,j)*(1.0-k_kij)
2541  DO k = 1,nhb_typ(i)
2542  DO l = 1,nhb_typ(j)
2543  IF (k /= l) THEN
2544  eps_hb(i,j,k,l)=(eps_hb(i,i,k,l)+eps_hb(j,j,l,k))/2.0
2545  ! eps_hb(i,j,k,l)=eps_hb(i,j,k,l)*(1.0-eps_kij)
2546  END IF
2547  END DO
2548  END DO
2549  END IF
2550  END DO
2551  END DO
2552  IF (nhb_typ(1) == 3) THEN
2553  eps_hb(1,2,3,1)=0.5*(eps_hb(1,1,3,1)+eps_hb(2,2,1,2))
2554  eps_hb(2,1,1,3) = eps_hb(1,2,3,1)
2555  END IF
2556  IF (nhb_typ(2) == 3) THEN
2557  eps_hb(2,1,3,1)=0.5*(eps_hb(2,2,3,1)+eps_hb(1,1,1,2))
2558  eps_hb(1,2,1,3) = eps_hb(2,1,3,1)
2559  END IF
2560 
2561  DO i = 1, ncomp
2562  DO k = 1, nhb_typ(i)
2563  DO j = 1, ncomp
2564  DO l = 1, nhb_typ(j)
2565  ! ass_d(i,j,k,l)=kap_hb(i,j) *sig_ij(i,j)**3 *(EXP(eps_hb(i,j,k,l)/t)-1.0)
2566  ass_d_dt(i,j,k,l)= - kap_hb(i,j) *sig_ij(i,j)**3 * eps_hb(i,j,k,l)/t/t*exp(eps_hb(i,j,k,l)/t)
2567  ass_d_dt2(i,j,k,l)= - kap_hb(i,j) *sig_ij(i,j)**3 &
2568  * eps_hb(i,j,k,l)/t/t*exp(eps_hb(i,j,k,l)/t) &
2569  * (-2.0/t - eps_hb(i,j,k,l)/t/t)
2570  END DO
2571  END DO
2572  END DO
2573  END DO
2574 
2575  DO i = 1, ncomp
2576  DO k = 1, nhb_typ(i)
2577  DO j = 1, ncomp
2578  DO l = 1, nhb_typ(j)
2579  delta(i,j,k,l)=gij(i,j)*ass_d(i,j,k,l)
2580  deltadt(i,j,k,l) = gijdt(i,j)*ass_d(i,j,k,l) + gij(i,j)*ass_d_dt(i,j,k,l)
2581  deltadt2(i,j,k,l)= gijdt2(i,j)*ass_d(i,j,k,l) &
2582  + 2.0*gijdt(i,j)*ass_d_dt(i,j,k,l) +gij(i,j)*ass_d_dt2(i,j,k,l)
2583  END DO
2584  END DO
2585  END DO
2586  END DO
2587 
2588 
2589 ! ------ constants for iteration ---------------------------------------
2590  attenu = 0.7
2591  tol = 1.e-10
2592  IF (eta < 0.2) tol = 1.e-11
2593  IF (eta < 0.01) tol = 1.e-12
2594  max_eval = 200
2595 
2596 ! ------ initialize mxdt(i,j) ------------------------------------------
2597  DO i = 1, ncomp
2598  DO k = 1, nhb_typ(i)
2599  mxdt(i,k) = 0.0
2600  mxdt2(i,k) = 0.0
2601  END DO
2602  END DO
2603 
2604 
2605 ! ------ iterate over all components and all sites ---------------------
2606  DO ass_cnt = 1, max_eval
2607 
2608  DO i = 1, ncomp
2609  DO k = 1, nhb_typ(i)
2610  suma = 0.0
2611  sumdt = 0.0
2612  sumdt2= 0.0
2613  DO j = 1, ncomp
2614  DO l = 1, nhb_typ(j)
2615  suma = suma + x(j)*nhb_no(j,l)* mx(j,l) *delta(i,j,k,l)
2616  sumdt = sumdt + x(j)*nhb_no(j,l)*( mx(j,l) *deltadt(i,j,k,l) &
2617  + mxdt(j,l)*delta(i,j,k,l) )
2618  sumdt2 = sumdt2 + x(j)*nhb_no(j,l)*( mx(j,l)*deltadt2(i,j,k,l) &
2619  + 2.0*mxdt(j,l)*deltadt(i,j,k,l) + mxdt2(j,l)*delta(i,j,k,l) )
2620  END DO
2621  END DO
2622  mx_itr(i,k) = 1.0 / (1.0 + suma * rho)
2623  mx_itrdt(i,k)= - mx_itr(i,k)**2 * sumdt*rho
2624  mx_itrdt2(i,k)= +2.0*mx_itr(i,k)**3 * (sumdt*rho)**2 - mx_itr(i,k)**2 *sumdt2*rho
2625  END DO
2626  END DO
2627 
2628  err_sum = 0.0
2629  DO i = 1, ncomp
2630  DO k = 1, nhb_typ(i)
2631  err_sum = err_sum + abs(mx_itr(i,k) - mx(i,k)) &
2632  + abs(mx_itrdt(i,k) - mxdt(i,k)) + abs(mx_itrdt2(i,k) - mxdt2(i,k))
2633  mx(i,k) = mx_itr(i,k) * attenu + mx(i,k) * (1.0 - attenu)
2634  mxdt(i,k)=mx_itrdt(i,k)*attenu +mxdt(i,k)* (1.0 - attenu)
2635  mxdt2(i,k)=mx_itrdt2(i,k)*attenu +mxdt2(i,k)* (1.0 - attenu)
2636  END DO
2637  END DO
2638  IF(err_sum <= tol) GO TO 10
2639 
2640  END DO
2641  WRITE(6,*) 'CAL_PCSAFT: max_eval violated err_sum = ',err_sum,tol
2642  stop
2643  10 CONTINUE
2644 
2645  DO i = 1, ncomp
2646  DO k = 1, nhb_typ(i)
2647  ! fhb = fhb + x(i)* nhb_no(i,k)* ( 0.5 * ( 1.0 - mx(i,k) ) + LOG(mx(i,k)) )
2648  fhbdt = fhbdt + x(i)*nhb_no(i,k) *mxdt(i,k)*(1.0/mx(i,k)-0.5)
2649  fhbdt2= fhbdt2 + x(i)*nhb_no(i,k) *(mxdt2(i,k)*(1.0/mx(i,k)-0.5) &
2650  -(mxdt(i,k)/mx(i,k))**2 )
2651  END DO
2652  END DO
2653 
2654 END IF
2655 
2656 
2657 ! ----------------------------------------------------------------------
2658 ! derivatives of f/kT of dipole-dipole term to temp. (fdddt)
2659 ! ----------------------------------------------------------------------
2660 fdddt = 0.0
2661 fdddt2 = 0.0
2662 dipole = 0
2663 DO i = 1,ncomp
2664  my2dd(i) = 0.0
2665  IF ( parame(i,6) /= 0.0 .AND. uij(i,i) /= 0.0 ) THEN
2666  dipole = 1
2667  my2dd(i) = (parame(i,6))**2 *1.e-49 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**3 *1.e-30)
2668  END IF
2669  my0(i) = my2dd(i) ! needed for dipole-quadrupole-term
2670 END DO
2671 
2672 IF (dipole == 1) THEN
2673  DO i = 1,ncomp
2674  DO j = 1,ncomp
2675  idd2(i,j) =0.0
2676  idd4(i,j) =0.0
2677  idd2dt(i,j) =0.0
2678  idd4dt(i,j) =0.0
2679  idd2dt2(i,j)=0.0
2680  idd4dt2(i,j)=0.0
2681  DO m=0,4
2682  idd2(i,j) = idd2(i,j) +ddp2(i,j,m)*z3**REAL(m)
2683  idd4(i,j) = idd4(i,j) +ddp4(i,j,m)*z3**REAL(m)
2684  idd2dt(i,j)= idd2dt(i,j) +ddp2(i,j,m)*z3dt*REAL(m)*z3**REAL(m-1)
2685  idd4dt(i,j)= idd4dt(i,j) +ddp4(i,j,m)*z3dt*REAL(m)*z3**REAL(m-1)
2686  idd2dt2(i,j)=idd2dt2(i,j)+ddp2(i,j,m)*z3dt2*REAL(m)*z3**REAL(m-1) &
2687  + ddp2(i,j,m)*z3dt**2 *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2688  idd4dt2(i,j)=idd4dt2(i,j)+ddp4(i,j,m)*z3dt2*REAL(m)*z3**REAL(m-1) &
2689  + ddp4(i,j,m)*z3dt**2 *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2690  END DO
2691  DO k = 1,ncomp
2692  idd3(i,j,k) =0.0
2693  idd3dt(i,j,k) =0.0
2694  idd3dt2(i,j,k)=0.0
2695  DO m = 0, 4
2696  idd3(i,j,k) = idd3(i,j,k) +ddp3(i,j,k,m)*z3**REAL(m)
2697  idd3dt(i,j,k) = idd3dt(i,j,k)+ddp3(i,j,k,m)*z3dt*REAL(m) *z3**REAL(m-1)
2698  idd3dt2(i,j,k)= idd3dt2(i,j,k)+ddp3(i,j,k,m)*z3dt2*REAL(m) &
2699  *z3**REAL(m-1) +ddp3(i,j,k,m)*z3dt**2 *REAL(m)*REAL(m-1) *z3**REAL(m-2)
2700  END DO
2701  END DO
2702  END DO
2703  END DO
2704 
2705 
2706  factor2= -pi *rho
2707  factor3= -4.0/3.0*pi**2 * rho**2
2708 
2709  fdd2 = 0.0
2710  fdd3 = 0.0
2711  fdd2dt= 0.0
2712  fdd3dt= 0.0
2713  fdd2dt2= 0.0
2714  fdd3dt2= 0.0
2715  DO i = 1, ncomp
2716  DO j = 1, ncomp
2717  xijmt = x(i)*parame(i,3)*parame(i,2)**3 *x(j)*parame(j,3)*parame(j,2)**3 &
2718  / ((parame(i,2)+parame(j,2))/2.0)**3 *my2dd(i)*my2dd(j)
2719  eij = (parame(i,3)*parame(j,3))**0.5
2720  fdd2 = fdd2 +factor2* xijmt/t/t*(idd2(i,j)+eij/t*idd4(i,j))
2721  fdd2dt= fdd2dt+ factor2* xijmt/t/t*(idd2dt(i,j)-2.0*idd2(i,j)/t &
2722  +eij/t*idd4dt(i,j)-3.0*eij/t/t*idd4(i,j))
2723  fdd2dt2=fdd2dt2+factor2*xijmt/t/t*(idd2dt2(i,j)-4.0*idd2dt(i,j)/t &
2724  +6.0*idd2(i,j)/t/t+eij/t*idd4dt2(i,j) &
2725  -6.0*eij/t/t*idd4dt(i,j)+12.0*eij/t**3 *idd4(i,j))
2726  DO k = 1, ncomp
2727  xijkmt=x(i)*parame(i,3)*parame(i,2)**3 &
2728  *x(j)*parame(j,3)*parame(j,2)**3 &
2729  *x(k)*parame(k,3)*parame(k,2)**3 &
2730  /((parame(i,2)+parame(j,2))/2.0) /((parame(i,2)+parame(k,2))/2.0) &
2731  /((parame(j,2)+parame(k,2))/2.0) *my2dd(i)*my2dd(j)*my2dd(k)
2732  fdd3 =fdd3 +factor3*xijkmt/t**3 *idd3(i,j,k)
2733  fdd3dt =fdd3dt +factor3*xijkmt/t**3 * (idd3dt(i,j,k)-3.0*idd3(i,j,k)/t)
2734  fdd3dt2=fdd3dt2+factor3*xijkmt/t**3 &
2735  *( idd3dt2(i,j,k)-6.0*idd3dt(i,j,k)/t+12.0*idd3(i,j,k)/t/t )
2736  END DO
2737  END DO
2738  END DO
2739 
2740  IF ( fdd2 < -1.e-100 .AND. fdd3 /= 0.0 ) THEN
2741  fdddt = fdd2* (fdd2*fdd2dt - 2.0*fdd3*fdd2dt+fdd2*fdd3dt) / (fdd2-fdd3)**2
2742  fdddt2 = ( 2.0*fdd2*fdd2dt*fdd2dt +fdd2*fdd2*fdd2dt2 &
2743  -2.0*fdd2dt**2 *fdd3 -2.0*fdd2*fdd2dt2*fdd3 +fdd2*fdd2*fdd3dt2 ) &
2744  /(fdd2-fdd3)**2 + fdddt * 2.0*(fdd3dt-fdd2dt)/(fdd2-fdd3)
2745  END IF
2746 END IF
2747 
2748 
2749 ! ----------------------------------------------------------------------
2750 ! derivatives f/kT of quadrupole-quadrup. term to T (fqqdt)
2751 ! ----------------------------------------------------------------------
2752 fqqdt = 0.0
2753 fqqdt2 = 0.0
2754 qudpole = 0
2755 DO i = 1, ncomp
2756  qq2(i) = (parame(i,7))**2 *1.e-69 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**5 *1.e-50)
2757  IF (qq2(i) /= 0.0) qudpole = 1
2758 END DO
2759 
2760 IF (qudpole == 1) THEN
2761 
2762  DO i = 1,ncomp
2763  DO j = 1,ncomp
2764  iqq2(i,j) = 0.0
2765  iqq4(i,j) = 0.0
2766  iqq2dt(i,j) = 0.0
2767  iqq4dt(i,j) = 0.0
2768  iqq2dt2(i,j)= 0.0
2769  iqq4dt2(i,j)= 0.0
2770  DO m = 0, 4
2771  iqq2(i,j) = iqq2(i,j) + qqp2(i,j,m)*z3**REAL(m)
2772  iqq4(i,j) = iqq4(i,j) + qqp4(i,j,m)*z3**REAL(m)
2773  iqq2dt(i,j) = iqq2dt(i,j)+ qqp2(i,j,m)*z3dt*REAL(m)*z3**REAL(m-1)
2774  iqq4dt(i,j) = iqq4dt(i,j)+ qqp4(i,j,m)*z3dt*REAL(m)*z3**REAL(m-1)
2775  iqq2dt2(i,j)= iqq2dt2(i,j)+qqp2(i,j,m)*z3dt2*REAL(m)*z3**REAL(m-1) &
2776  + qqp2(i,j,m)*z3dt**2 *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2777  iqq4dt2(i,j)= iqq4dt2(i,j)+qqp4(i,j,m)*z3dt2*REAL(m)*z3**REAL(m-1) &
2778  + qqp4(i,j,m)*z3dt**2 *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2779  END DO
2780  DO k = 1,ncomp
2781  iqq3(i,j,k) =0.0
2782  iqq3dt(i,j,k) =0.0
2783  iqq3dt2(i,j,k)=0.0
2784  DO m = 0, 4
2785  iqq3(i,j,k) = iqq3(i,j,k) + qqp3(i,j,k,m)*z3**REAL(m)
2786  iqq3dt(i,j,k) = iqq3dt(i,j,k)+ qqp3(i,j,k,m)*z3dt*REAL(m) * z3**REAL(m-1)
2787  iqq3dt2(i,j,k)= iqq3dt2(i,j,k)+qqp3(i,j,k,m)*z3dt2*REAL(m) * z3**REAL(m-1) &
2788  + qqp3(i,j,k,m)*z3dt**2 *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2789  END DO
2790  END DO
2791  END DO
2792  END DO
2793 
2794  factor2 = -9.0/16.0 * pi *rho
2795  factor3 = 9.0/16.0 * pi**2 * rho**2
2796 
2797  fqq2 = 0.0
2798  fqq3 = 0.0
2799  fqq2dt = 0.0
2800  fqq3dt = 0.0
2801  fqq2dt2= 0.0
2802  fqq3dt2= 0.0
2803  DO i = 1,ncomp
2804  DO j = 1,ncomp
2805  xijmt = x(i)*uij(i,i)*qq2(i)*sig_ij(i,i)**5 &
2806  * x(j)*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /sig_ij(i,j)**7.0
2807  eij = (parame(i,3)*parame(j,3))**0.5
2808  fqq2 = fqq2 +factor2* xijmt/t/t*(iqq2(i,j)+eij/t*iqq4(i,j))
2809  fqq2dt= fqq2dt +factor2* xijmt/t/t*(iqq2dt(i,j)-2.0*iqq2(i,j)/t &
2810  + eij/t*iqq4dt(i,j)-3.0*eij/t/t*iqq4(i,j))
2811  fqq2dt2=fqq2dt2+factor2*xijmt/t/t*(iqq2dt2(i,j)-4.0*iqq2dt(i,j)/t &
2812  + 6.0*iqq2(i,j)/t/t+eij/t*iqq4dt2(i,j) &
2813  - 6.0*eij/t/t*iqq4dt(i,j)+12.0*eij/t**3 *iqq4(i,j))
2814  DO k = 1,ncomp
2815  xijkmt = x(i)*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /sig_ij(i,j)**3 &
2816  * x(j)*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /sig_ij(i,k)**3 &
2817  * x(k)*uij(k,k)*qq2(k)*sig_ij(k,k)**5 /sig_ij(j,k)**3
2818  fqq3 = fqq3 +factor3*xijkmt/t**3 *iqq3(i,j,k)
2819  fqq3dt = fqq3dt +factor3*xijkmt/t**3 *(iqq3dt(i,j,k)-3.0*iqq3(i,j,k)/t)
2820  fqq3dt2= fqq3dt2+factor3*xijkmt/t**3 &
2821  * ( iqq3dt2(i,j,k)-6.0*iqq3dt(i,j,k)/t+12.0*iqq3(i,j,k)/t/t )
2822  END DO
2823  END DO
2824  END DO
2825 
2826  IF ( fqq2 /= 0.0 .AND. fqq3 /= 0.0 ) THEN
2827  fqqdt = fqq2* (fqq2*fqq2dt - 2.0*fqq3*fqq2dt+fqq2*fqq3dt) / (fqq2-fqq3)**2
2828  fqqdt2 = ( 2.0*fqq2*fqq2dt*fqq2dt +fqq2*fqq2*fqq2dt2 &
2829  - 2.0*fqq2dt**2 *fqq3 -2.0*fqq2*fqq2dt2*fqq3 +fqq2*fqq2*fqq3dt2 ) &
2830  / (fqq2-fqq3)**2 + fqqdt * 2.0*(fqq3dt-fqq2dt)/(fqq2-fqq3)
2831  END IF
2832 
2833 END IF
2834 
2835 
2836 ! ----------------------------------------------------------------------
2837 ! derivatives f/kT of dipole-quadruppole term to T (fdqdt)
2838 ! ----------------------------------------------------------------------
2839 fdqdt = 0.0
2840 fdqdt2= 0.0
2841 dip_quad = 0
2842 DO i = 1,ncomp
2843  DO j = 1,ncomp
2844  IF (parame(i,6) /= 0.0 .AND. parame(j,7) /= 0.0) dip_quad = 1
2845  END DO
2846  myfac(i) = parame(i,3)*parame(i,2)**4 *my0(i)
2847  q_fac(i) = parame(i,3)*parame(i,2)**4 *qq2(i)
2848 END DO
2849 
2850 IF (dip_quad == 1) THEN
2851 
2852  DO i = 1,ncomp
2853  DO j = 1,ncomp
2854  idq2(i,j) = 0.0
2855  idq4(i,j) = 0.0
2856  idq2dt(i,j) = 0.0
2857  idq4dt(i,j) = 0.0
2858  idq2dt2(i,j)= 0.0
2859  idq4dt2(i,j)= 0.0
2860  IF ( myfac(i) /= 0.0 .AND. q_fac(j) /= 0.0 ) THEN
2861  DO m = 0, 4
2862  idq2(i,j) = idq2(i,j) + dqp2(i,j,m)*z3**REAL(m)
2863  idq4(i,j) = idq4(i,j) + dqp4(i,j,m)*z3**REAL(m)
2864  idq2dt(i,j) = idq2dt(i,j)+ dqp2(i,j,m)*z3dt*REAL(m)*z3**REAL(m-1)
2865  idq4dt(i,j) = idq4dt(i,j)+ dqp4(i,j,m)*z3dt*REAL(m)*z3**REAL(m-1)
2866  idq2dt2(i,j)= idq2dt2(i,j)+dqp2(i,j,m)*z3dt2*REAL(m)*z3**REAL(m-1) &
2867  + dqp2(i,j,m)*z3dt**2 *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2868  idq4dt2(i,j)= idq4dt2(i,j)+dqp4(i,j,m)*z3dt2*REAL(m)*z3**REAL(m-1) &
2869  + dqp4(i,j,m)*z3dt**2 *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2870  END DO
2871 
2872  DO k = 1,ncomp
2873  idq3(i,j,k) = 0.0
2874  idq3dt(i,j,k) = 0.0
2875  idq3dt2(i,j,k)= 0.0
2876  IF ( myfac(k) /= 0.0 .OR. q_fac(k) /= 0.0 ) THEN
2877  DO m = 0, 4
2878  idq3(i,j,k) = idq3(i,j,k) + dqp3(i,j,k,m)*z3**REAL(m)
2879  idq3dt(i,j,k)= idq3dt(i,j,k)+ dqp3(i,j,k,m)*z3dt*REAL(m) *z3**REAL(m-1)
2880  idq3dt2(i,j,k)= idq3dt2(i,j,k)+dqp3(i,j,k,m)*z3dt2*REAL(m) *z3**REAL(m-1) &
2881  + dqp3(i,j,k,m)*z3dt**2 *REAL(m)*REAL(m-1)*z3**REAL(m-2)
2882  END DO
2883  END IF
2884  END DO
2885  END IF
2886  END DO
2887  END DO
2888 
2889  factor2= -9.0/4.0 * pi * rho
2890  factor3= pi**2 * rho**2
2891 
2892  fdq2 = 0.0
2893  fdq3 = 0.0
2894  fdq2dt= 0.0
2895  fdq3dt= 0.0
2896  fdq2dt2=0.0
2897  fdq3dt2=0.0
2898  DO i = 1,ncomp
2899  DO j = 1,ncomp
2900  IF ( myfac(i) /= 0.0 .AND. q_fac(j) /= 0.0 ) THEN
2901  xijmt = x(i)*myfac(i) * x(j)*q_fac(j) /sig_ij(i,j)**5
2902  eij = (parame(i,3)*parame(j,3))**0.5
2903  fdq2 = fdq2 + factor2* xijmt/t/t*(idq2(i,j)+eij/t*idq4(i,j))
2904  fdq2dt= fdq2dt+ factor2* xijmt/t/t*(idq2dt(i,j)-2.0*idq2(i,j)/t &
2905  + eij/t*idq4dt(i,j)-3.0*eij/t/t*idq4(i,j))
2906  fdq2dt2 = fdq2dt2+factor2*xijmt/t/t*(idq2dt2(i,j)-4.0*idq2dt(i,j)/t &
2907  + 6.0*idq2(i,j)/t/t+eij/t*idq4dt2(i,j) &
2908  - 6.0*eij/t/t*idq4dt(i,j)+12.0*eij/t**3 *idq4(i,j))
2909  DO k = 1,ncomp
2910  IF ( myfac(k) /= 0.0 .OR. q_fac(k) /= 0.0 ) THEN
2911  xijkmt= x(i)*x(j)*x(k)/(sig_ij(i,j)*sig_ij(i,k)*sig_ij(j,k))**2 &
2912  * ( myfac(i)*q_fac(j)*myfac(k) &
2913  + myfac(i)*q_fac(j)*q_fac(k)*1.193735 )
2914 
2915  fdq3 =fdq3 + factor3*xijkmt/t**3 *idq3(i,j,k)
2916  fdq3dt=fdq3dt+ factor3*xijkmt/t**3 * (idq3dt(i,j,k)-3.0*idq3(i,j,k)/t)
2917  fdq3dt2=fdq3dt2+factor3*xijkmt/t**3 &
2918  *( idq3dt2(i,j,k)-6.0*idq3dt(i,j,k)/t+12.0*idq3(i,j,k)/t/t )
2919  END IF
2920  END DO
2921  END IF
2922  END DO
2923  END DO
2924 
2925  IF (fdq2 /= 0.0 .AND. fdq3 /= 0.0) THEN
2926  fdqdt = fdq2* (fdq2*fdq2dt - 2.0*fdq3*fdq2dt+fdq2*fdq3dt) / (fdq2-fdq3)**2
2927  fdqdt2 = ( 2.0*fdq2*fdq2dt*fdq2dt +fdq2*fdq2*fdq2dt2 &
2928  - 2.0*fdq2dt**2 *fdq3 -2.0*fdq2*fdq2dt2*fdq3 +fdq2*fdq2*fdq3dt2 ) &
2929  / (fdq2-fdq3)**2 + fdqdt * 2.0*(fdq3dt-fdq2dt)/(fdq2-fdq3)
2930  END IF
2931 
2932 END IF
2933 ! ----------------------------------------------------------------------
2934 
2935 
2936 
2937 
2938 ! ----------------------------------------------------------------------
2939 ! total derivative of fres/kT to temperature
2940 ! ----------------------------------------------------------------------
2941 
2942 df_dt = fhsdt + fchdt + fdspdt + fhbdt + fdddt + fqqdt + fdqdt
2943 
2944 
2945 
2946 ! ----------------------------------------------------------------------
2947 ! second derivative of fres/kT to T
2948 ! ----------------------------------------------------------------------
2949 
2950 df_dt2 = fhsdt2 +fchdt2 +fdspdt2 +fhbdt2 +fdddt2 +fqqdt2 +fdqdt2
2951 
2952 
2953 
2954 ! ----------------------------------------------------------------------
2955 ! ------ derivatives of fres/kt to density and to T --------------------
2956 ! ----------------------------------------------------------------------
2957 
2958 ! ----------------------------------------------------------------------
2959 ! the analytic derivative of fres/kT to (density and T) (df_drdt)
2960 ! is still missing. A numerical differentiation is implemented.
2961 ! ----------------------------------------------------------------------
2962 fact = 1.0
2963 dist = t * 100.e-5 * fact
2964 t_tmp = t
2965 rho_0 = rho
2966 
2967 
2968 t = t_tmp - 2.0*dist
2969 CALL perturbation_parameter
2970 eta = z3t*rho_0
2971 CALL p_eos
2972 fdr1 = pges / (eta*rho_0*(kbol*t)/1.e-30)
2973 t = t_tmp - dist
2974 CALL perturbation_parameter
2975 eta = z3t*rho_0
2976 CALL p_eos
2977 fdr2 = pges / (eta*rho_0*(kbol*t)/1.e-30)
2978 
2979 t = t_tmp + dist
2980 CALL perturbation_parameter
2981 eta = z3t*rho_0
2982 CALL p_eos
2983 fdr3 = pges / (eta*rho_0*(kbol*t)/1.e-30)
2984 
2985 t = t_tmp + 2.0*dist
2986 CALL perturbation_parameter
2987 eta = z3t*rho_0
2988 CALL p_eos
2989 fdr4 = pges / (eta*rho_0*(kbol*t)/1.e-30)
2990 
2991 t = t_tmp
2992 CALL perturbation_parameter
2993 eta = z3t*rho_0
2994 CALL p_eos
2995 
2996 
2997 df_drdt = (-fdr4+8.0*fdr3-8.0*fdr2+fdr1)/(12.0*dist)
2998 
2999 
3000 
3001 
3002 
3003 ! ----------------------------------------------------------------------
3004 ! thermodynamic properties
3005 ! ----------------------------------------------------------------------
3006 
3007 s_res = ( - df_dt *t - fres )*rgas + rgas * log(zges)
3008 h_res = ( - t*df_dt + zges-1.0 ) * rgas *t
3009 cv_res = - ( t*df_dt2 + 2.0*df_dt ) * rgas*t
3010 cp_res = cv_res - rgas + rgas*(zges +eta*t*df_drdt)**2 &
3011  / (1.0 + 2.0*eta*dfdr +eta**2 *ddfdrdr)
3012 
3013 ! write (*,*) 'df_... ', df_dt,df_dt2
3014 ! write (*,*) 'kreuz ', zges,eta*t*df_drdt,eta*dfdr, eta**2 *ddfdrdr
3015 ! write (*,*) 'h,cv,cp', h_res,cv_res,cp_res
3016 
3017 
3018 END SUBROUTINE h_eos
3019 
3020 
3021 
3022 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
3023 ! SUBROUTINE H_EOS_num
3024 !
3025 ! This subroutine calculates enthalpies and heat capacities (cp) by
3026 ! taking numerical derivatieves.
3027 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
3028 !
3029  SUBROUTINE h_eos_num
3030 !
3031  USE parameters, ONLY: rgas
3032  USE eos_variables
3033  IMPLICIT NONE
3034 !
3035 !---------------------------------------------------------------------
3036  REAL :: dist, fact, rho_0
3037  REAL :: fres1, fres2, fres3, fres4, fres5
3038  REAL :: f_1, f_2, f_3, f_4
3039  REAL :: cv_res, t_tmp, zges
3040  REAL :: df_dt, df_dtdt, df_drdt, dfdr, ddfdrdr
3041 
3042 !-----------------------------------------------------------------------
3043 
3044 
3045 CALL perturbation_parameter
3046 rho_0 = eta/z3t
3047 
3048 
3049 fact = 1.0
3050 dist = t * 100.e-5 * fact
3051 
3052 t_tmp = t
3053 
3054 t = t_tmp - 2.0*dist
3055 CALL perturbation_parameter
3056 eta = z3t*rho_0
3057 CALL f_eos
3058 fres1 = fres
3059 t = t_tmp - dist
3060 CALL perturbation_parameter
3061 eta = z3t*rho_0
3062 CALL f_eos
3063 fres2 = fres
3064 t = t_tmp + dist
3065 CALL perturbation_parameter
3066 eta = z3t*rho_0
3067 CALL f_eos
3068 fres3 = fres
3069 t = t_tmp + 2.0*dist
3070 CALL perturbation_parameter
3071 eta = z3t*rho_0
3072 CALL f_eos
3073 fres4 = fres
3074 t = t_tmp
3075 CALL perturbation_parameter
3076 eta = z3t*rho_0
3077 CALL f_eos
3078 fres5 = fres
3079 ! *(KBOL*T)/1.E-30
3080 
3081 zges = (p * 1.e-30)/(kbol*t*rho_0)
3082 
3083 
3084 df_dt = (-fres4+8.0*fres3-8.0*fres2+fres1)/(12.0*dist)
3085 df_dtdt = (-fres4+16.0*fres3-3.d1*fres5+16.0*fres2-fres1) &
3086  /(12.0*(dist**2 ))
3087 
3088 
3089 s_res = (- df_dt -fres/t)*rgas*t + rgas * log(zges)
3090 h_res = ( - t*df_dt + zges-1.0 ) * rgas*t
3091 cv_res = -( t*df_dtdt + 2.0*df_dt ) * rgas*t
3092 
3093 
3094 
3095 t = t_tmp - 2.0*dist
3096 CALL perturbation_parameter
3097 eta = z3t*rho_0
3098 CALL p_eos
3099 f_1 = pges/(eta*rho_0*(kbol*t)/1.e-30)
3100 
3101 t = t_tmp - dist
3102 CALL perturbation_parameter
3103 eta = z3t*rho_0
3104 CALL p_eos
3105 f_2 = pges/(eta*rho_0*(kbol*t)/1.e-30)
3106 
3107 t = t_tmp + dist
3108 CALL perturbation_parameter
3109 eta = z3t*rho_0
3110 CALL p_eos
3111 f_3 = pges/(eta*rho_0*(kbol*t)/1.e-30)
3112 
3113 t = t_tmp + 2.0*dist
3114 CALL perturbation_parameter
3115 eta = z3t*rho_0
3116 CALL p_eos
3117 f_4 = pges/(eta*rho_0*(kbol*t)/1.e-30)
3118 
3119 t = t_tmp
3120 CALL perturbation_parameter
3121 eta = z3t*rho_0
3122 CALL p_eos
3123 
3124 dfdr = pges / (eta*rho_0*(kbol*t)/1.e-30)
3125 ddfdrdr = pgesdz/(eta*rho_0*(kbol*t)/1.e-30) - dfdr*2.0/eta - 1.0/eta**2
3126 
3127 df_drdt = ( -f_4 +8.0*f_3 -8.0*f_2 +f_1) / (12.0*dist)
3128 
3129 cp_res = cv_res - rgas +rgas*(zges+eta*t*df_drdt)**2 &
3130  * 1.0/(1.0 + 2.0*eta*dfdr + eta**2 *ddfdrdr)
3131 
3132 ! write (*,*) 'n',df_dt,df_dtdt
3133 ! write (*,*) 'kreuz ', zges,eta*t*df_drdt,eta*dfdr, eta**2 *ddfdrdr
3134 ! write (*,*) 'h, cv', h_res, cv_res
3135 ! write (*,*) h_res - t*s_res
3136 ! write (*,*) cv_res,cp_res,eta
3137 ! pause
3138 
3139 END SUBROUTINE h_eos_num
3140 
3141 
3150  SUBROUTINE density_iteration
3151 !
3152  USE basic_variables, ONLY: num
3153  USE eos_variables
3154  IMPLICIT NONE
3155 !
3156 ! ----------------------------------------------------------------------
3157  INTEGER :: i, start, max_i
3158  REAL :: eta_iteration
3159  REAL :: error, dydx, acc_i, delta_eta
3160 ! ----------------------------------------------------------------------
3161 
3162 
3163 IF ( densav(phas) /= 0.0 .AND. eta_start == denold(phas) ) THEN
3164  denold(phas) = eta_start
3165  eta_start = densav(phas)
3166 ELSE
3167  denold(phas) = eta_start
3168  densav(phas) = eta_start
3169 END IF
3170 
3171 
3172 acc_i = 1.d-9
3173 max_i = 30
3174 density_error(:) = 0.0
3175 
3176 i = 0
3177 eta_iteration = eta_start
3178 
3179 ! ----------------------------------------------------------------------
3180 ! iterate density until p_calc = p
3181 ! ----------------------------------------------------------------------
3182 iterate_density: DO
3183 
3184  i = i + 1
3185  eta = eta_iteration
3186 
3187  IF ( num == 0 ) THEN
3188  CALL p_eos
3189  ELSE IF ( num == 1 ) THEN
3190  CALL p_numerical
3191  ELSE IF ( num == 2 ) THEN
3192  WRITE(*,*) 'CRITICAL RENORM NOT INCLUDED YET'
3193  !!CALL F_EOS_RN
3194  ELSE
3195  write (*,*) 'define calculation option (num)'
3196  END IF
3197 
3198  error = (pges / p ) - 1.0
3199 
3200  ! --- instable region correction -------------------------------------
3201  IF ( pgesdz < 0.0 .AND. i < max_i ) THEN
3202  IF ( error > 0.0 .AND. pgesd2 > 0.0 ) THEN ! no liquid density
3203  CALL pressure_spinodal
3204  eta_iteration = eta
3205  error = (pges / p ) - 1.0
3206  IF ( ((pges/p ) -1.0) > 0.0 ) eta_iteration = 0.001 ! no solution possible
3207  IF ( ((pges/p ) -1.0) <=0.0 ) eta_iteration = eta_iteration * 1.1 ! no solution found so far
3208  ELSE IF ( error < 0.0 .AND. pgesd2 < 0.0 ) THEN ! no vapor density
3209  CALL pressure_spinodal
3210  eta_iteration = eta
3211  error = (pges / p ) - 1.0
3212  IF ( ((pges/p ) -1.0) < 0.0 ) eta_iteration = 0.5 ! no solution possible
3213  IF ( ((pges/p ) -1.0) >=0.0 ) eta_iteration = eta_iteration * 0.9 ! no solution found so far
3214  ELSE
3215  eta_iteration = (eta_iteration + eta_start) / 2.0
3216  IF (eta_iteration == eta_start) eta_iteration = eta_iteration + 0.2
3217  END IF
3218  cycle iterate_density
3219  END IF
3220 
3221 
3222  dydx = pgesdz/p
3223  delta_eta = error/ dydx
3224  IF ( delta_eta > 0.05 ) delta_eta = 0.05
3225  IF ( delta_eta < -0.05 ) delta_eta = -0.05
3226 
3227  eta_iteration = eta_iteration - delta_eta
3228 
3229  IF (eta_iteration > 0.9) eta_iteration = 0.6
3230  IF (eta_iteration <= 0.0) eta_iteration = 1.e-16
3231  start = 1
3232 
3233  IF ( abs(error*p/pgesdz) < 1.d-12 ) start = 0
3234  IF ( abs(error) < acc_i ) start = 0
3235  IF ( i > max_i ) THEN
3236  start = 0
3237  density_error(phas) = abs( error )
3238  ! write (*,*) 'density iteration failed'
3239  END IF
3240 
3241  IF (start /= 1) EXIT iterate_density
3242 
3243 END DO iterate_density
3244 
3245 eta = eta_iteration
3246 
3247 IF ((eta > 0.3 .AND. densav(phas) > 0.3) .OR. &
3248  (eta < 0.1 .AND. densav(phas) < 0.1)) densav(phas) = eta
3249 
3250 END SUBROUTINE density_iteration
3251 
3252 
3253 
3254 
3262  SUBROUTINE f_eos
3263 !
3264  USE parameters, ONLY: nc, nsite
3265  USE eos_variables
3266  USE eos_constants
3267  IMPLICIT NONE
3268 !
3269 ! --- local variables --------------------------------------------------
3270  INTEGER :: i, j, k, l, m, n
3271  REAL :: z0, z1, z2, z3
3272  REAL :: zms, m_mean ! ,lij(nc,nc)
3273  REAL :: i1,i2, c1_con
3274  REAL :: fhs, fdsp, fhc
3275 
3276  LOGICAL :: assoc
3277  INTEGER :: ass_cnt,max_eval
3278  REAL :: delta(nc,nc,nsite,nsite)
3279  REAL :: mx_itr(nc,nsite), err_sum, sum, attenu, tol, fhb
3280  REAL :: ass_s1, ass_s2
3281 
3282  REAL :: fdd, fqq, fdq
3283 ! ----------------------------------------------------------------------
3284 
3285 
3286 ! ----------------------------------------------------------------------
3287 ! abbreviations
3288 ! ----------------------------------------------------------------------
3289 rho = eta/z3t
3290 z0 = z0t*rho
3291 z1 = z1t*rho
3292 z2 = z2t*rho
3293 z3 = z3t*rho
3294 
3295 m_mean = z0t / ( pi / 6.0 )
3296 zms = 1.0 - eta
3297 
3298 ! m_mean2 = 0.0
3299 ! lij(1,2) = -0.05
3300 ! lij(2,1) = lij(1,2)
3301 ! DO i = 1, ncomp
3302 ! DO j = 1, ncomp
3303 ! m_mean2 = m_mean2 + x(i)*x(j)*(mseg(i)+mseg(j))/2.0*(1.0-lij(i,j))
3304 ! ENDDO
3305 ! ENDDO
3306 
3307 
3308 ! ----------------------------------------------------------------------
3309 ! radial distr. function at contact, gij
3310 ! ----------------------------------------------------------------------
3311 DO i = 1, ncomp
3312  DO j=1,ncomp
3313  gij(i,j) = 1.0/zms + 3.0*dij_ab(i,j)*z2/zms/zms + 2.0*(dij_ab(i,j)*z2)**2 /zms**3
3314  END DO
3315 END DO
3316 
3317 
3318 ! ----------------------------------------------------------------------
3319 ! Helmholtz energy : hard sphere contribution
3320 ! ----------------------------------------------------------------------
3321 fhs= m_mean*( 3.0*z1*z2/zms + z2**3 /z3/zms/zms + (z2**3 /z3/z3-z0)*log(zms) )/z0
3322 
3323 
3324 ! ----------------------------------------------------------------------
3325 ! Helmholtz energy : chain term
3326 ! ----------------------------------------------------------------------
3327 fhc = 0.0
3328 DO i = 1, ncomp
3329  fhc = fhc + x(i) *(1.0- mseg(i)) *log(gij(i,i))
3330 END DO
3331 
3332 
3333 ! ----------------------------------------------------------------------
3334 ! Helmholtz energy : PC-SAFT dispersion contribution
3335 ! ----------------------------------------------------------------------
3336 IF (eos == 1) THEN
3337 
3338  i1 = 0.0
3339  i2 = 0.0
3340  DO m = 0, 6
3341  i1 = i1 + apar(m)*eta**REAL(m)
3342  i2 = i2 + bpar(m)*eta**REAL(m)
3343  END DO
3344 
3345  c1_con= 1.0/ ( 1.0 + m_mean*(8.0*eta-2.0*eta**2 )/zms**4 &
3346  + (1.0 - m_mean)*(20.0*eta-27.0*eta**2 &
3347  + 12.0*eta**3 -2.0*eta**4 ) /(zms*(2.0-eta))**2 )
3348 
3349  fdsp = -2.0*pi*rho*i1*order1 - pi*rho*c1_con*m_mean*i2*order2
3350 
3351 ! ----------------------------------------------------------------------
3352 ! Helmholtz energy : SAFT (Chen, Kreglewski) dispersion contribution
3353 ! ----------------------------------------------------------------------
3354 ELSE
3355 
3356  fdsp = 0.0
3357  DO n = 1,4
3358  DO m = 1,9
3359  fdsp = fdsp + dnm(n,m) * (um/t)**REAL(n) *(eta/tau)**REAL(m)
3360  END DO
3361  END DO
3362  fdsp = m_mean * fdsp
3363 
3364 END IF
3365 
3366 
3367 ! ----------------------------------------------------------------------
3368 ! TPT-1-association according to Chapman et al.
3369 ! ----------------------------------------------------------------------
3370 fhb = 0.0
3371 assoc = .false.
3372 DO i = 1, ncomp
3373  IF (nhb_typ(i) /= 0) assoc = .true.
3374 END DO
3375 IF (assoc) THEN
3376 
3377  DO i = 1, ncomp
3378  DO k = 1, nhb_typ(i)
3379  IF (mx(i,k) == 0.0) mx(i,k) = 1.0 ! Initialize mx(i,j)
3380  DO j = 1, ncomp
3381  DO l = 1, nhb_typ(j)
3382  delta(i,j,k,l) = gij(i,j) * ass_d(i,j,k,l)
3383  END DO
3384  END DO
3385  END DO
3386  END DO
3387 
3388 
3389 ! --- constants for iteration ------------------------------------------
3390  attenu = 0.70
3391  tol = 1.d-10
3392  IF (eta < 0.2) tol = 1.d-12
3393  IF (eta < 0.01) tol = 1.d-13
3394  max_eval = 200
3395 
3396 ! --- iterate over all components and all sites ------------------------
3397  ass_cnt = 0
3398  iterate_tpt1: DO
3399 
3400  ass_cnt = ass_cnt + 1
3401 
3402  DO i = 1, ncomp
3403  DO k = 1, nhb_typ(i)
3404  sum = 0.0
3405  DO j = 1, ncomp
3406  DO l = 1, nhb_typ(j)
3407  sum = sum + x(j)* mx(j,l)*nhb_no(j,l) *delta(i,j,k,l)
3408 ! if (ass_cnt == 1) write (*,*) j,l,x(j), mx(j,l)
3409  END DO
3410  END DO
3411  mx_itr(i,k) = 1.0 / (1.0 + sum * rho)
3412 ! if (ass_cnt == 1) write (*,*) 'B',ass_cnt,sum, rho
3413  END DO
3414  END DO
3415 
3416  err_sum = 0.0
3417  DO i = 1, ncomp
3418  DO k = 1, nhb_typ(i)
3419  err_sum = err_sum + abs(mx_itr(i,k) - mx(i,k)) ! / ABS(mx_itr(i,k))
3420  mx(i,k) = mx_itr(i,k) * attenu + mx(i,k) * (1.0 - attenu)
3421  END DO
3422  END DO
3423 
3424  IF ( err_sum <= tol .OR. ass_cnt >= max_eval ) THEN
3425  IF (ass_cnt >= max_eval) WRITE(*,'(a,2G15.7)') 'F_EOS: Max_eval violated (mx) Err_Sum = ',err_sum,tol
3426  EXIT iterate_tpt1
3427  END IF
3428 
3429  END DO iterate_tpt1
3430 
3431  DO i = 1, ncomp
3432  ass_s1 = 0.0
3433  ass_s2 = 0.0
3434  DO k = 1, nhb_typ(i)
3435  ass_s1 = ass_s1 + nhb_no(i,k) * ( 1.0 - mx(i,k) )
3436  ass_s2 = ass_s2 + nhb_no(i,k) * log( mx(i,k) )
3437  END DO
3438  fhb = fhb + x(i) * ( ass_s2 + ass_s1 / 2.0 )
3439  END DO
3440 
3441 END IF
3442 ! --- TPT-1-association accord. to Chapman -----------------------------
3443 
3444 
3445 ! ----------------------------------------------------------------------
3446 ! polar terms
3447 ! ----------------------------------------------------------------------
3448  CALL f_polar ( fdd, fqq, fdq )
3449 
3450 
3451 ! ----------------------------------------------------------------------
3452 ! resid. Helmholtz energy f/kT
3453 ! ----------------------------------------------------------------------
3454 fres = fhs + fhc + fdsp + fhb + fdd + fqq + fdq
3455 
3456 tfr= fres
3457 
3458 END SUBROUTINE f_eos
3459 
3460 
3461 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
3462 !
3463 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
3464 !
3465  SUBROUTINE f_numerical
3466 !
3467  USE eos_variables
3468  USE eos_constants
3469  USE eos_numerical_derivatives, ONLY: ideal_gas, hard_sphere, chain_term, &
3470  disp_term, hb_term, lc_term, branch_term, &
3471  ii_term, id_term, subtract1, subtract2
3472  IMPLICIT NONE
3473 !
3474 !---------------------------------------------------------------------
3475 
3476 !-----local variables-------------------------------------------------
3477  INTEGER :: i, j
3478  REAL :: m_mean2
3479  REAL :: fid, fhs, fdsp, fhc
3480  REAL :: fhb, fdd, fqq, fdq
3481  REAL :: fhend, fcc
3482  REAL :: fbr, flc
3483  REAL :: fref
3484 
3485  REAL :: eps_kij, k_kij
3486 !---------------------------------------------------------------------
3487 
3488 eps_kij = 0.0
3489 k_kij = 0.0
3490 
3491 fid = 0.0
3492 fhs = 0.0
3493 fhc = 0.0
3494 fdsp= 0.0
3495 fhb = 0.0
3496 fdd = 0.0
3497 fqq = 0.0
3498 fdq = 0.0
3499 fcc = 0.0
3500 fbr = 0.0
3501 flc = 0.0
3502 
3503 
3504 CALL perturbation_parameter
3505 
3506 ! ----------------------------------------------------------------------
3507 ! overwrite the standard mixing rules by those published by Tang & Gross
3508 ! using an additional lij parameter
3509 ! WARNING : the lij parameter is set to lij = - lji in 'para_input'
3510 ! ----------------------------------------------------------------------
3511 order1 = 0.0
3512 order2 = 0.0
3513 DO i = 1, ncomp
3514  DO j = 1, ncomp
3515  order1 = order1 + x(i)*x(j)* mseg(i)*mseg(j) * sig_ij(i,j)**3 * uij(i,j)/t
3516  order2 = order2 + x(i)*x(j)* mseg(i)*mseg(j) * sig_ij(i,j)**3 * (uij(i,j)/t)**2
3517  END DO
3518 END DO
3519 DO i = 1, ncomp
3520  DO j = 1, ncomp
3521  order1 = order1 + x(i)*mseg(i)/t*( x(j)*mseg(j) &
3522  *sig_ij(i,j)*(uij(i,i)*uij(j,j))**(1.0/6.0) )**3 *lij(i,j)
3523  END DO
3524 END DO
3525 
3526 
3527 ! ----------------------------------------------------------------------
3528 ! a non-standard mixing rule scaling the hard-sphere term
3529 ! WARNING : the lij parameter is set to lij = - lji in 'para_input'
3530 ! (uses an additional lij parameter)
3531 ! ----------------------------------------------------------------------
3532 m_mean2 = 0.0
3533 DO i = 1, ncomp
3534  DO j = 1, ncomp
3535  m_mean2 = m_mean2 + x(i)*x(j)*(mseg(i)+mseg(j))/2.0
3536  END DO
3537 END DO
3538 DO i = 1, ncomp
3539  DO j = 1, ncomp
3540  ! m_mean2=m_mean2+x(i)*(x(j)*((mseg(i)+mseg(j))*0.5)**(1.0/3.0) *lij(i,j) )**3
3541  END DO
3542 END DO
3543 
3544 ! --- ideal gas contribution -------------------------------------------
3545 IF ( ideal_gas == 'yes' ) CALL f_ideal_gas ( fid )
3546 ! ----------------------------------------------------------------------
3547 
3548 ! --- hard-sphere contribution -----------------------------------------
3549 IF ( hard_sphere == 'CSBM' ) CALL f_hard_sphere ( m_mean2, fhs )
3550 ! ----------------------------------------------------------------------
3551 
3552 ! -- chain term --------------------------------------------------------
3553 IF ( chain_term == 'TPT1' ) CALL f_chain_tpt1 ( fhc )
3554 IF ( chain_term == 'TPT2' ) CALL f_chain_tpt_d ( fhc )
3555 IF ( chain_term == 'HuLiu' ) CALL f_chain_hu_liu ( fhc )
3556 IF ( chain_term == 'HuLiu_rc' ) CALL f_chain_hu_liu_rc ( fhs, fhc )
3557 !!IF ( chain_term == 'SPT' ) CALL F_SPT ( fhs, fhc )
3558 IF ( chain_term == 'SPT' ) WRITE(*,*) 'SPT NOT INCLUDED YET'
3559 ! ----------------------------------------------------------------------
3560 
3561 ! --- dispersive attraction --------------------------------------------
3562 IF ( disp_term == 'PC-SAFT') CALL f_disp_pcsaft ( fdsp )
3563 IF ( disp_term == 'CK') CALL f_disp_cksaft ( fdsp )
3564 IF ( disp_term(1:2) == 'PT') CALL f_pert_theory ( fdsp )
3565 ! ----------------------------------------------------------------------
3566 
3567 ! --- H-bonding contribution / Association -----------------------------
3568 IF ( hb_term == 'TPT1_Chap') CALL f_association( eps_kij, k_kij, fhb )
3569 ! ----------------------------------------------------------------------
3570 
3571 ! --- polar terms ------------------------------------------------------
3572  CALL f_polar ( fdd, fqq, fdq )
3573 ! ----------------------------------------------------------------------
3574 
3575 ! --- ion-dipole term --------------------------------------------------
3576 IF ( id_term == 'TBH') CALL f_ion_dipole_tbh ( fhend )
3577 ! ----------------------------------------------------------------------
3578 
3579 ! --- ion-ion term -----------------------------------------------------
3580 IF ( ii_term == 'primMSA') CALL f_ion_ion_primmsa ( fcc )
3581 IF ( ii_term == 'nprMSA') CALL f_ion_ion_nonprimmsa ( fdd, fqq, fdq, fcc )
3582 ! ----------------------------------------------------------------------
3583 
3584 ! --- liquid-crystal term ----------------------------------------------
3585 IF ( lc_term == 'MSaupe') CALL f_lc_mayersaupe ( flc )
3586 
3587 !!IF ( LC_term == 'OVL') fref = fhs + fhc
3588 IF ( lc_term == 'OVL') WRITE(*,*) 'OVL NOT INCLUDED YET'
3589 !IF ( LC_term == 'OVL') CALL F_LC_OVL ( fref, flc )
3590 !! IF ( LC_term == 'SPT') fref = fhs + fhc
3591 IF ( lc_term == 'SPT') WRITE(*,*) 'SPT NOT INCLUDED YET'
3592 !!IF ( LC_term == 'SPT') CALL F_LC_SPT( fref, flc )
3593 ! ----------------------------------------------------------------------
3594 
3595 ! ======================================================================
3596 ! SUBTRACT TERMS (local density approximation) FOR DFT
3597 ! ======================================================================
3598 
3599 !IF ( subtract1 == '1PT') CALL F_subtract_local_pert_theory ( subtract1, fdsp )
3600 !IF ( subtract1 == '2PT') CALL F_subtract_local_pert_theory ( subtract1, fdsp )
3601 !IF ( subtract2 =='ITTpolar') CALL F_local_ITT_polar ( fdd )
3602 ! ----------------------------------------------------------------------
3603 
3604 ! ----------------------------------------------------------------------
3605 ! residual Helmholtz energy F/(NkT)
3606 ! ----------------------------------------------------------------------
3607 fres = fid + fhs + fhc + fdsp + fhb + fdd + fqq + fdq + fcc + flc
3608 
3609 tfr = 0.0
3610 
3611 END SUBROUTINE f_numerical
3612 
3613 
3614 
3615 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
3616 ! SUBROUTINE P_EOS
3617 !
3618 ! calculates the pressure in units (Pa).
3619 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
3620 !
3621  SUBROUTINE p_eos
3622 !
3623 ! ----------------------------------------------------------------------
3624  USE parameters, ONLY: nc, nsite
3625  USE eos_variables
3626  USE eos_constants
3627  IMPLICIT NONE
3628 !
3629 ! --- local variables --------------------------------------------------
3630  INTEGER :: i, j, k, l, m, n
3631  INTEGER :: ass_cnt,max_eval
3632  LOGICAL :: assoc
3633  REAL :: z0, z1, z2, z3
3634  REAL :: zms, m_mean
3635  REAL :: zges, zgesdz, zgesd2, zgesd3
3636  REAL :: zhs, zhsdz, zhsd2, zhsd3
3637  REAL :: zhc, zhcdz, zhcd2, zhcd3
3638  REAL, DIMENSION(nc,nc) :: dgijdz, dgijd2, dgijd3, dgijd4
3639  REAL :: zdsp, zdspdz, zdspd2, zdspd3
3640  REAL :: c1_con, c2_con, c3_con, c4_con, c5_con
3641  REAL :: i2, edi1dz, edi2dz, edi1d2, edi2d2
3642  REAL :: edi1d3, edi2d3, edi1d4, edi2d4
3643  REAL :: fdspdz,fdspd2
3644  REAL :: zhb, zhbdz, zhbd2, zhbd3
3645  REAL, DIMENSION(nc,nc,nsite,nsite) :: delta, dq_dz, dq_d2, dq_d3, dq_d4
3646  REAL, DIMENSION(nc,nsite) :: mx_itr, dmx_dz, ndmxdz, dmx_d2, ndmxd2
3647  REAL, DIMENSION(nc,nsite) :: dmx_d3, ndmxd3, dmx_d4, ndmxd4
3648  REAL :: err_sum, sum0, sum1, sum2, sum3, sum4, attenu, tol
3649  REAL :: sum_d1, sum_d2, sum_d3, sum_d4
3650  REAL :: zdd, zddz, zddz2, zddz3
3651  REAL :: zqq, zqqz, zqqz2, zqqz3
3652  REAL :: zdq, zdqz, zdqz2, zdqz3
3653 ! ----------------------------------------------------------------------
3654 
3655 
3656 ! ----------------------------------------------------------------------
3657 ! abbreviations
3658 ! ----------------------------------------------------------------------
3659 rho = eta/z3t
3660 z0 = z0t*rho
3661 z1 = z1t*rho
3662 z2 = z2t*rho
3663 z3 = z3t*rho
3664 
3665 m_mean = z0t/(pi/6.0)
3666 zms = 1.0 -eta
3667 
3668 ! m_mean2=0.0
3669 ! lij(1,2)= -0.050
3670 ! lij(2,1)=lij(1,2)
3671 ! DO i =1,ncomp
3672 ! DO j =1,ncomp
3673 ! m_mean2=m_mean2+x(i)*x(j) * (mseg(i)+mseg(j))/2.0*(1.0-lij(i,j))
3674 ! ENDDO
3675 ! ENDDO
3676 
3677 
3678 ! ----------------------------------------------------------------------
3679 ! radial distr. function at contact, gij , and derivatives
3680 ! dgijdz=d(gij)/d(eta) and dgijd2 = dd(gij)/d(eta)**2
3681 ! ----------------------------------------------------------------------
3682 DO i = 1, ncomp
3683  DO j=1,ncomp
3684  ! j=i
3685  gij(i,j) = 1.0/zms + 3.0*dij_ab(i,j)*z2/zms/zms + 2.0*(dij_ab(i,j)*z2)**2 /zms**3
3686  dgijdz(i,j)= 1.0/zms/zms + 3.0*dij_ab(i,j)*z2*(1.0+z3)/z3/zms**3 &
3687  + (dij_ab(i,j)*z2/zms/zms)**2 *(4.0+2.0*z3)/z3
3688  dgijd2(i,j) = 2.0/zms**3 &
3689  + 6.0*dij_ab(i,j)*z2/z3/zms**4 *(2.0+z3) &
3690  + (2.0*dij_ab(i,j)*z2/z3)**2 /zms**5 *(1.0+4.0*z3+z3*z3)
3691  dgijd3(i,j) = 6.0/zms**4 &
3692  + 18.0*dij_ab(i,j)*z2/z3/zms**5 *(3.0+z3) &
3693  + 12.0*(dij_ab(i,j)*z2/z3/zms**3 )**2 *(3.0+6.0*z3+z3*z3)
3694  dgijd4(i,j) = 24.0/zms**5 &
3695  + 72.0*dij_ab(i,j)*z2/z3/zms**6 *(4.0+z3) &
3696  + 48.0*(dij_ab(i,j)*z2/z3)**2 /zms**7 *(6.0+8.0*z3+z3*z3)
3697  END DO
3698 END DO
3699 
3700 
3701 ! ----------------------------------------------------------------------
3702 ! p : hard sphere contribution
3703 ! ----------------------------------------------------------------------
3704 zhs = m_mean* ( z3/zms + 3.0*z1*z2/z0/zms/zms + z2**3 /z0*(3.0-z3)/zms**3 )
3705 zhsdz = m_mean*( 1.0/zms/zms + 3.0*z1*z2/z0/z3*(1.0+z3)/zms**3 &
3706  + 6.0*z2**3 /z0/z3/zms**4 )
3707 zhsd2 = m_mean*( 2.0/zms**3 + 6.0*z1*z2/z0/z3*(2.0+z3)/zms**4 &
3708  + 6.0*z2**3 /z0/z3/z3*(1.0+3.0*z3)/zms**5 )
3709 zhsd3 = m_mean*( 6.0/zms**4 + 18.0*z1*z2/z0/z3*(3.0+z3)/zms**5 &
3710  + 24.0*z2**3 /z0/z3/z3*(2.0+3.0*z3)/zms**6 )
3711 
3712 
3713 ! ----------------------------------------------------------------------
3714 ! p : chain term
3715 ! ----------------------------------------------------------------------
3716 zhc = 0.0
3717 zhcdz = 0.0
3718 zhcd2 = 0.0
3719 zhcd3 = 0.0
3720 DO i= 1, ncomp
3721  zhc = zhc + x(i)*(1.0-mseg(i))*eta/gij(i,i)* dgijdz(i,i)
3722  zhcdz = zhcdz + x(i)*(1.0-mseg(i)) *(-eta*(dgijdz(i,i)/gij(i,i))**2 &
3723  + dgijdz(i,i)/gij(i,i) + eta/gij(i,i)*dgijd2(i,i))
3724  zhcd2 = zhcd2 + x(i)*(1.0-mseg(i)) &
3725  *( 2.0*eta*(dgijdz(i,i)/gij(i,i))**3 &
3726  -2.0*(dgijdz(i,i)/gij(i,i))**2 &
3727  -3.0*eta/gij(i,i)**2 *dgijdz(i,i)*dgijd2(i,i) &
3728  +2.0/gij(i,i)*dgijd2(i,i) +eta/gij(i,i)*dgijd3(i,i) )
3729  zhcd3 = zhcd3 + x(i)*(1.0-mseg(i)) *( 6.0*(dgijdz(i,i)/gij(i,i))**3 &
3730  -6.0*eta*(dgijdz(i,i)/gij(i,i))**4 &
3731  +12.0*eta/gij(i,i)**3 *dgijdz(i,i)**2 *dgijd2(i,i) &
3732  -9.0/gij(i,i)**2 *dgijdz(i,i)*dgijd2(i,i) +3.0/gij(i,i)*dgijd3(i,i) &
3733  -3.0*eta*(dgijd2(i,i)/gij(i,i))**2 &
3734  -4.0*eta/gij(i,i)**2 *dgijdz(i,i)*dgijd3(i,i) &
3735  +eta/gij(i,i)*dgijd4(i,i) )
3736 END DO
3737 
3738 ! ----------------------------------------------------------------------
3739 ! p : PC-SAFT dispersion contribution
3740 ! note: edI1dz is equal to d(eta*I1)/d(eta), analogous for edI2dz
3741 ! ----------------------------------------------------------------------
3742 IF (eos == 1) THEN
3743 
3744  i2 = 0.0
3745  edi1dz = 0.0
3746  edi2dz = 0.0
3747  edi1d2 = 0.0
3748  edi2d2 = 0.0
3749  edi1d3 = 0.0
3750  edi2d3 = 0.0
3751  edi1d4 = 0.0
3752  edi2d4 = 0.0
3753  DO m=0,6
3754  i2 = i2 + bpar(m)*z3**REAL(m)
3755  edi1dz= edi1dz+apar(m)*REAL(m+1)*z3**REAL(m)
3756  edi2dz= edi2dz+bpar(m)*REAL(m+1)*z3**REAL(m)
3757  edi1d2= edi1d2+apar(m)*REAL((m+1)*m)*z3**REAL(m-1)
3758  edi2d2= edi2d2+bpar(m)*REAL((m+1)*m)*z3**REAL(m-1)
3759  edi1d3= edi1d3+apar(m)*REAL((m+1)*m*(m-1))*z3**REAL(m-2)
3760  edi2d3= edi2d3+bpar(m)*REAL((m+1)*m*(m-1))*z3**REAL(m-2)
3761  edi1d4= edi1d4+apar(m)*REAL((m+1)*m*(m-1)*(m-2))*z3**REAL(m-3)
3762  edi2d4= edi2d4+bpar(m)*REAL((m+1)*m*(m-1)*(m-2))*z3**REAL(m-3)
3763  END DO
3764 
3765  c1_con= 1.0/ ( 1.0 + m_mean*(8.0*eta-2.0*eta**2 )/zms**4 &
3766  + (1.0 - m_mean)*(20.0*eta-27.0*eta**2 &
3767  + 12.0*eta**3 -2.0*eta**4 ) /(zms*(2.0-eta))**2 )
3768  c2_con= - c1_con*c1_con &
3769  *(m_mean*(-4.0*eta**2 +20.0*eta+8.0)/zms**5 + (1.0 - m_mean) &
3770  *(2.0*eta**3 +12.0*eta**2 -48.0*eta+40.0) &
3771  /(zms*(2.0-eta))**3 )
3772  c3_con= 2.0 * c2_con*c2_con/c1_con - c1_con*c1_con &
3773  *( m_mean*(-12.0*eta**2 +72.0*eta+60.0)/zms**6 &
3774  + (1.0 - m_mean) &
3775  *(-6.0*eta**4 -48.0*eta**3 +288.0*eta**2 &
3776  -480.0*eta+264.0) /(zms*(2.0-eta))**4 )
3777  c4_con= 6.0*c2_con*c3_con/c1_con -6.0*c2_con**3 /c1_con**2 &
3778  - c1_con*c1_con &
3779  *( m_mean*(-48.0*eta**2 +336.0*eta+432.0)/zms**7 &
3780  + (1.0 - m_mean) &
3781  *(24.0*eta**5 +240.0*eta**4 -1920.0*eta**3 &
3782  +4800.0*eta**2 -5280.0*eta+2208.0) /(zms*(2.0-eta))**5 )
3783  c5_con= 6.0*c3_con**2 /c1_con - 36.0*c2_con**2 /c1_con**2 *c3_con &
3784  + 8.0*c2_con/c1_con*c4_con+24.0*c2_con**4 /c1_con**3 &
3785  - c1_con*c1_con &
3786  *( m_mean*(-240.0*eta**2 +1920.0*eta+3360.0)/zms**8 &
3787  + (1.0 - m_mean) &
3788  *(-120.0*eta**6 -1440.0*eta**5 +14400.0*eta**4 &
3789  -48000.0*eta**3 +79200.0*eta**2 -66240.0*eta+22560.0) &
3790  /(zms*(2.0-eta))**6 )
3791 
3792  zdsp = - 2.0*pi*rho*edi1dz*order1 &
3793  - pi*rho*order2*m_mean*(c2_con*i2*eta + c1_con*edi2dz)
3794  zdspdz= zdsp/eta - 2.0*pi*rho*edi1d2*order1 &
3795  - pi*rho*order2*m_mean*(c3_con*i2*eta &
3796  + 2.0*c2_con*edi2dz + c1_con*edi2d2)
3797  zdspd2= -2.0*zdsp/eta/eta +2.0*zdspdz/eta &
3798  - 2.0*pi*rho*edi1d3*order1 - pi*rho*order2*m_mean*(c4_con*i2*eta &
3799  + 3.0*c3_con*edi2dz +3.0*c2_con*edi2d2 +c1_con*edi2d3)
3800  zdspd3= 6.0*zdsp/eta**3 -6.0*zdspdz/eta/eta &
3801  + 3.0*zdspd2/eta - 2.0*pi*rho*edi1d4*order1 &
3802  - pi*rho*order2*m_mean*(c5_con*i2*eta &
3803  + 4.0*c4_con*edi2dz +6.0*c3_con*edi2d2 &
3804  + 4.0*c2_con*edi2d3 + c1_con*edi2d4)
3805 
3806 
3807 ! ----------------------------------------------------------------------
3808 ! p : SAFT (Chen & Kreglewski) dispersion contribution
3809 ! ----------------------------------------------------------------------
3810 ELSE
3811 
3812  fdspdz = 0.0
3813  fdspd2 = 0.0
3814  DO n = 1,4
3815  DO m = 1,9
3816  fdspdz = fdspdz + m_mean/tau * dnm(n,m) * (um/t)**REAL(n) *REAL(m)*(eta/tau)**REAL(m-1)
3817  END DO
3818  DO m= 2,9
3819  fdspd2= fdspd2 + m_mean/tau * dnm(n,m)*(um/t)**REAL(n) *REAL(m)*REAL(m-1) &
3820  * (eta/tau)**REAL(m-2) * 1.0/tau
3821  END DO
3822  END DO
3823  zdsp = eta * fdspdz
3824  zdspdz = (2.0*fdspdz + eta*fdspd2) - zdsp/z3
3825 
3826 END IF
3827 ! --- end of dispersion contribution -----------------------------------
3828 
3829 
3830 ! ----------------------------------------------------------------------
3831 ! p: TPT-1-association accord. to Chapman et al.
3832 ! ----------------------------------------------------------------------
3833 zhb = 0.0
3834 zhbdz = 0.0
3835 zhbd2 = 0.0
3836 zhbd3 = 0.0
3837 assoc = .false.
3838 DO i = 1,ncomp
3839  IF (nhb_typ(i) /= 0) assoc = .true.
3840 END DO
3841 IF (assoc) THEN
3842 
3843  DO j = 1, ncomp
3844  DO i = 1, nhb_typ(j)
3845  DO k = 1, ncomp
3846  DO l = 1, nhb_typ(k)
3847  delta(j,k,i,l) = gij(j,k) * ass_d(j,k,i,l)
3848  dq_dz(j,k,i,l) = dgijdz(j,k) * ass_d(j,k,i,l)
3849  dq_d2(j,k,i,l) = dgijd2(j,k) * ass_d(j,k,i,l)
3850  dq_d3(j,k,i,l) = dgijd3(j,k) * ass_d(j,k,i,l)
3851  dq_d4(j,k,i,l) = dgijd4(j,k) * ass_d(j,k,i,l)
3852  END DO
3853  END DO
3854  END DO
3855  END DO
3856 
3857 ! --- constants for iteration ------------------------------------------
3858  attenu = 0.7
3859  tol = 1.d-10
3860  IF ( eta < 0.2 ) tol = 1.d-12
3861  IF ( eta < 0.01 ) tol = 1.d-13
3862  IF ( eta < 1.e-6) tol = 1.d-15
3863  max_eval = 1000
3864 
3865 ! --- initialize mx(i,j) -----------------------------------------------
3866  DO i = 1, ncomp
3867  DO j = 1, nhb_typ(i)
3868  mx(i,j) = 1.0
3869  dmx_dz(i,j) = 0.0
3870  dmx_d2(i,j) = 0.0
3871  dmx_d3(i,j) = 0.0
3872  dmx_d4(i,j) = 0.0
3873  END DO
3874  END DO
3875 
3876 ! --- iterate over all components and all sites ------------------------
3877  ass_cnt = 0
3878  err_sum = tol + 1.0
3879  DO WHILE ( err_sum > tol .AND. ass_cnt <= max_eval)
3880  ass_cnt = ass_cnt + 1
3881  DO i = 1, ncomp
3882  DO j = 1, nhb_typ(i)
3883  sum0 = 0.0
3884  sum1 = 0.0
3885  sum2 = 0.0
3886  sum3 = 0.0
3887  sum4 = 0.0
3888  DO k = 1, ncomp
3889  DO l = 1, nhb_typ(k)
3890  sum0 =sum0 +x(k)*nhb_no(k,l)* mx(k,l)* delta(i,k,j,l)
3891  sum1 =sum1 +x(k)*nhb_no(k,l)*( mx(k,l)* dq_dz(i,k,j,l) &
3892  + dmx_dz(k,l)* delta(i,k,j,l))
3893  sum2 =sum2 +x(k)*nhb_no(k,l)*( mx(k,l)* dq_d2(i,k,j,l) &
3894  + 2.0*dmx_dz(k,l)* dq_dz(i,k,j,l) &
3895  + dmx_d2(k,l)* delta(i,k,j,l))
3896  sum3 =sum3 +x(k)*nhb_no(k,l)*( mx(k,l)* dq_d3(i,k,j,l) &
3897  + 3.0*dmx_dz(k,l)* dq_d2(i,k,j,l) &
3898  + 3.0*dmx_d2(k,l)* dq_dz(i,k,j,l) &
3899  + dmx_d3(k,l)* delta(i,k,j,l))
3900  sum4 =sum4 + x(k)*nhb_no(k,l)*( mx(k,l)* dq_d4(i,k,j,l) &
3901  + 4.0*dmx_dz(k,l)* dq_d3(i,k,j,l) &
3902  + 6.0*dmx_d2(k,l)* dq_d2(i,k,j,l) &
3903  + 4.0*dmx_d3(k,l)* dq_dz(i,k,j,l) &
3904  + dmx_d4(k,l)* delta(i,k,j,l))
3905  END DO
3906  END DO
3907  mx_itr(i,j)= 1.0 / (1.0 + sum0 * rho)
3908  ndmxdz(i,j)= -(mx_itr(i,j)*mx_itr(i,j))* (sum0/z3t +sum1*rho)
3909  ndmxd2(i,j)= + 2.0/mx_itr(i,j)*ndmxdz(i,j)*ndmxdz(i,j) &
3910  - (mx_itr(i,j)*mx_itr(i,j)) * (2.0/z3t*sum1 + rho*sum2)
3911  ndmxd3(i,j)= - 6.0/mx_itr(i,j)**2 *ndmxdz(i,j)**3 &
3912  + 6.0/mx_itr(i,j)*ndmxdz(i,j)*ndmxd2(i,j) - mx_itr(i,j)*mx_itr(i,j) &
3913  * (3.0/z3t*sum2 + rho*sum3)
3914  ndmxd4(i,j)= 24.0/mx_itr(i,j)**3 *ndmxdz(i,j)**4 &
3915  -36.0/mx_itr(i,j)**2 *ndmxdz(i,j)**2 *ndmxd2(i,j) &
3916  +6.0/mx_itr(i,j)*ndmxd2(i,j)**2 &
3917  +8.0/mx_itr(i,j)*ndmxdz(i,j)*ndmxd3(i,j) - mx_itr(i,j)**2 &
3918  *(4.0/z3t*sum3 + rho*sum4)
3919  END DO
3920  END DO
3921 
3922  err_sum = 0.0
3923  DO i = 1, ncomp
3924  DO j = 1, nhb_typ(i)
3925  err_sum = err_sum + abs(mx_itr(i,j) - mx(i,j)) &
3926  + abs(ndmxdz(i,j) - dmx_dz(i,j)) + abs(ndmxd2(i,j) - dmx_d2(i,j))
3927  mx(i,j) = mx_itr(i,j)*attenu + mx(i,j) * (1.0-attenu)
3928  dmx_dz(i,j) = ndmxdz(i,j)*attenu + dmx_dz(i,j) * (1.0-attenu)
3929  dmx_d2(i,j) = ndmxd2(i,j)*attenu + dmx_d2(i,j) * (1.0-attenu)
3930  dmx_d3(i,j) = ndmxd3(i,j)*attenu + dmx_d3(i,j) * (1.0-attenu)
3931  dmx_d4(i,j) = ndmxd4(i,j)*attenu + dmx_d4(i,j) * (1.0-attenu)
3932  END DO
3933  END DO
3934  END DO
3935 
3936  IF ( ass_cnt >= max_eval .AND. err_sum > sqrt(tol) ) THEN
3937  WRITE (*,'(a,2G15.7)') 'P_EOS: Max_eval violated (mx) Err_Sum= ',err_sum,tol
3938  ! stop
3939  END IF
3940 
3941 
3942  ! --- calculate the hydrogen-bonding contribution --------------------
3943  DO i = 1, ncomp
3944  sum_d1 = 0.0
3945  sum_d2 = 0.0
3946  sum_d3 = 0.0
3947  sum_d4 = 0.0
3948  DO j = 1, nhb_typ(i)
3949  sum_d1= sum_d1 +nhb_no(i,j)* dmx_dz(i,j)*(1.0/mx(i,j)-0.5)
3950  sum_d2= sum_d2 +nhb_no(i,j)*(dmx_d2(i,j)*(1.0/mx(i,j)-0.5) &
3951  -(dmx_dz(i,j)/mx(i,j))**2 )
3952  sum_d3= sum_d3 +nhb_no(i,j)*(dmx_d3(i,j)*(1.0/mx(i,j)-0.5) &
3953  -3.0/mx(i,j)**2 *dmx_dz(i,j)*dmx_d2(i,j) + 2.0*(dmx_dz(i,j)/mx(i,j))**3 )
3954  sum_d4= sum_d4 +nhb_no(i,j)*(dmx_d4(i,j)*(1.0/mx(i,j)-0.5) &
3955  -4.0/mx(i,j)**2 *dmx_dz(i,j)*dmx_d3(i,j) &
3956  + 12.0/mx(i,j)**3 *dmx_dz(i,j)**2 *dmx_d2(i,j) &
3957  - 3.0/mx(i,j)**2 *dmx_d2(i,j)**2 - 6.0*(dmx_dz(i,j)/mx(i,j))**4 )
3958  END DO
3959  zhb = zhb + x(i) * eta * sum_d1
3960  zhbdz = zhbdz + x(i) * eta * sum_d2
3961  zhbd2 = zhbd2 + x(i) * eta * sum_d3
3962  zhbd3 = zhbd3 + x(i) * eta * sum_d4
3963  END DO
3964  zhbdz = zhbdz + zhb/eta
3965  zhbd2 = zhbd2 + 2.0/eta*zhbdz-2.0/eta**2 *zhb
3966  zhbd3 = zhbd3 - 6.0/eta**2 *zhbdz+3.0/eta*zhbd2 + 6.0/eta**3 *zhb
3967 END IF
3968 ! --- TPT-1-association accord. to Chapman -----------------------------
3969 
3970 
3971 ! ----------------------------------------------------------------------
3972 ! p: polar terms
3973 ! ----------------------------------------------------------------------
3974 CALL p_polar ( zdd, zddz, zddz2, zddz3, zqq, zqqz, zqqz2, zqqz3, zdq, zdqz, zdqz2, zdqz3 )
3975 
3976 
3977 ! ----------------------------------------------------------------------
3978 ! compressibility factor z and total p
3979 ! as well as derivatives d(z)/d(eta) and d(p)/d(eta) with unit [Pa]
3980 ! ----------------------------------------------------------------------
3981 zges = 1.0 + zhs + zhc + zdsp + zhb + zdd + zqq + zdq
3982 zgesdz = zhsdz + zhcdz + zdspdz + zhbdz + zddz + zqqz + zdqz
3983 zgesd2 = zhsd2 + zhcd2 + zdspd2 + zhbd2 + zddz2 +zqqz2+zdqz2
3984 zgesd3 = zhsd3 + zhcd3 + zdspd3 + zhbd3 + zddz3 +zqqz3+zdqz3
3985 
3986 pges = zges *rho *(kbol*t)/1.d-30
3987 pgesdz = ( zgesdz*rho + zges*rho/z3 )*(kbol*t)/1.d-30
3988 pgesd2 = ( zgesd2*rho + 2.0*zgesdz*rho/z3 )*(kbol*t)/1.d-30
3989 pgesd3 = ( zgesd3*rho + 3.0*zgesd2*rho/z3 )*(kbol*t)/1.d-30
3990 
3991 END SUBROUTINE p_eos
3992 
3993 
3994 
3995 
3996 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
3997 !
3998 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
3999 !
4000  SUBROUTINE phi_polar ( k, z3_rk, fdd_rk, fqq_rk, fdq_rk )
4001 !
4002  USE eos_variables, ONLY: ncomp, parame, dd_term, qq_term, dq_term
4003  IMPLICIT NONE
4004 !
4005 ! ----------------------------------------------------------------------
4006  INTEGER, INTENT(IN) :: k
4007  REAL, INTENT(IN) :: z3_rk
4008  REAL, INTENT(OUT) :: fdd_rk, fqq_rk, fdq_rk
4009 !
4010 ! --- local variables---------------------------------------------------
4011  INTEGER :: dipole
4012  INTEGER :: quadrupole
4013  INTEGER :: dipole_quad
4014 ! ----------------------------------------------------------------------
4015 
4016  fdd_rk = 0.0
4017  fqq_rk = 0.0
4018  fdq_rk = 0.0
4019 
4020  dipole = 0
4021  quadrupole = 0
4022  dipole_quad = 0
4023  IF ( sum( parame(1:ncomp,6) ) /= 0.0 ) dipole = 1
4024  IF ( sum( parame(1:ncomp,7) ) /= 0.0 ) quadrupole = 1
4025  IF ( dipole == 1 .AND. quadrupole == 1 ) dipole_quad = 1
4026 
4027  ! --------------------------------------------------------------------
4028  ! dipole-dipole term
4029  ! --------------------------------------------------------------------
4030  IF (dipole == 1) THEN
4031 
4032  IF (dd_term == 'GV') CALL phi_dd_gross_vrabec( k, z3_rk, fdd_rk )
4033  ! IF (dd_term == 'SF') CALL PHI_DD_SAAGER_FISCHER( k )
4034 
4035  IF (dd_term /= 'GV' .AND. dd_term /= 'SF') write (*,*) 'specify dipole term !'
4036 
4037  ENDIF
4038 
4039  ! --------------------------------------------------------------------
4040  ! quadrupole-quadrupole term
4041  ! --------------------------------------------------------------------
4042  IF (quadrupole == 1) THEN
4043 
4044  !IF (qq_term == 'SF') CALL PHI_QQ_SAAGER_FISCHER( k )
4045  IF (qq_term == 'JG') CALL phi_qq_gross( k, z3_rk, fqq_rk )
4046 
4047  IF (qq_term /= 'JG' .AND. qq_term /= 'SF') write (*,*) 'specify quadrupole term !'
4048 
4049  ENDIF
4050 
4051  ! --------------------------------------------------------------------
4052  ! dipole-quadrupole cross term
4053  ! --------------------------------------------------------------------
4054  IF (dipole_quad == 1) THEN
4055 
4056  IF (dq_term == 'VG') CALL phi_dq_vrabec_gross( k, z3_rk, fdq_rk )
4057 
4058  IF (dq_term /= 'VG' ) write (*,*) 'specify DQ-cross term !'
4059 
4060  ENDIF
4061 
4062 END SUBROUTINE phi_polar
4063 
4064 
4065 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4066 !
4067 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4068 !
4069  SUBROUTINE phi_dd_gross_vrabec( k, z3_rk, fdd_rk )
4070 !
4071  USE parameters, ONLY: pi, kbol
4072  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
4073  USE eos_constants, ONLY: ddp2, ddp3, ddp4
4074  IMPLICIT NONE
4075 !
4076 ! ----------------------------------------------------------------------
4077  INTEGER, INTENT(IN) :: k
4078  REAL, INTENT(IN) :: z3_rk
4079  REAL, INTENT(IN OUT) :: fdd_rk
4080 !
4081 ! --- local variables---------------------------------------------------
4082  INTEGER :: i, j, l, m
4083 
4084  REAL :: factor2, factor3, z3
4085  REAL :: xijfa, xijkfa, xijfa_x, xijkf_x, eij
4086  REAL :: fdd2, fdd3, fdd2x, fdd3x
4087  REAL, DIMENSION(nc) :: my2dd
4088  REAL, DIMENSION(nc,nc) :: idd2, idd4, idd2x, idd4x
4089  REAL, DIMENSION(nc,nc,nc) :: idd3, idd3x
4090 ! ----------------------------------------------------------------------
4091 
4092 
4093  fdd_rk = 0.0
4094  z3 = eta
4095  DO i = 1, ncomp
4096  IF ( uij(i,i) == 0.0 ) write (*,*) 'PHI_DD_GROSS_VRABEC: do not use dimensionless units'
4097  IF ( uij(i,i) == 0.0 ) stop
4098  my2dd(i) = (parame(i,6))**2 *1.e-49 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**3 *1.e-30)
4099  END DO
4100 
4101  DO i = 1, ncomp
4102  DO j = 1, ncomp
4103  idd2(i,j) = 0.0
4104  idd4(i,j) = 0.0
4105  idd2x(i,j) = 0.0
4106  idd4x(i,j) = 0.0
4107  IF (parame(i,6) /= 0.0 .AND. parame(j,6) /= 0.0) THEN
4108  DO m=0,4
4109  idd2(i,j) =idd2(i,j) + ddp2(i,j,m)*z3**m
4110  idd4(i,j) =idd4(i,j) + ddp4(i,j,m)*z3**m
4111  idd2x(i,j) =idd2x(i,j)+ ddp2(i,j,m)*REAL(m)*z3**(m-1)*z3_rk
4112  idd4x(i,j) =idd4x(i,j)+ ddp4(i,j,m)*REAL(m)*z3**(m-1)*z3_rk
4113  END DO
4114  DO l = 1, ncomp
4115  idd3(i,j,l) = 0.0
4116  idd3x(i,j,l) = 0.0
4117  IF (parame(l,6) /= 0.0) THEN
4118  DO m=0,4
4119  idd3(i,j,l) =idd3(i,j,l) +ddp3(i,j,l,m)*z3**m
4120  idd3x(i,j,l)=idd3x(i,j,l)+ddp3(i,j,l,m)*REAL(m)*z3**(m-1)*z3_rk
4121  END DO
4122  END IF
4123  END DO
4124  END IF
4125  END DO
4126  END DO
4127 
4128  factor2= -pi
4129  factor3= -4.0/3.0*pi**2
4130 
4131  fdd2 = 0.0
4132  fdd3 = 0.0
4133  fdd2x = 0.0
4134  fdd3x = 0.0
4135  DO i = 1, ncomp
4136  xijfa_x = 2.0*x(i)*rho*uij(i,i)*my2dd(i)*sig_ij(i,i)**3 /t &
4137  *uij(k,k)*my2dd(k)*sig_ij(k,k)**3 /t/sig_ij(i,k)**3
4138  eij = (parame(i,3)*parame(k,3))**0.5
4139  fdd2x = fdd2x + factor2*xijfa_x*( idd2(i,k) + eij/t*idd4(i,k) )
4140  DO j = 1, ncomp
4141  IF (parame(i,6) /= 0.0 .AND. parame(j,6) /= 0.0) THEN
4142  xijfa =x(i)*rho*uij(i,i)*my2dd(i)*sig_ij(i,i)**3 /t &
4143  *x(j)*rho*uij(j,j)*my2dd(j)*sig_ij(j,j)**3 /t/sig_ij(i,j)**3
4144  eij = (parame(i,3)*parame(j,3))**0.5
4145  fdd2= fdd2 +factor2*xijfa*(idd2(i,j) +eij/t*idd4(i,j) )
4146  fdd2x =fdd2x +factor2*xijfa*(idd2x(i,j)+eij/t*idd4x(i,j))
4147  !---------------------
4148  xijkf_x=x(i)*rho*uij(i,i)*my2dd(i)*sig_ij(i,i)**3 /t/sig_ij(i,j) &
4149  *x(j)*rho*uij(j,j)*my2dd(j)*sig_ij(j,j)**3 /t/sig_ij(i,k) &
4150  *3.0* uij(k,k)*my2dd(k)*sig_ij(k,k)**3 /t/sig_ij(j,k)
4151  fdd3x=fdd3x+factor3*xijkf_x*idd3(i,j,k)
4152  DO l=1,ncomp
4153  IF (parame(l,6) /= 0.0) THEN
4154  xijkfa= x(i)*rho*uij(i,i)/t*my2dd(i)*sig_ij(i,i)**3 &
4155  *x(j)*rho*uij(j,j)/t*my2dd(j)*sig_ij(j,j)**3 &
4156  *x(l)*rho*uij(l,l)/t*my2dd(l)*sig_ij(l,l)**3 &
4157  /sig_ij(i,j)/sig_ij(i,l)/sig_ij(j,l)
4158  fdd3 =fdd3 + factor3 * xijkfa *idd3(i,j,l)
4159  fdd3x =fdd3x + factor3 * xijkfa *idd3x(i,j,l)
4160  END IF
4161  END DO
4162  END IF
4163  END DO
4164  END DO
4165 
4166  IF (fdd2 < -1.e-50 .AND. fdd3 /= 0.0 .AND. fdd2x /= 0.0 .AND. fdd3x /= 0.0)THEN
4167 
4168  fdd_rk = fdd2* (fdd2*fdd2x - 2.0*fdd3*fdd2x+fdd2*fdd3x) / (fdd2-fdd3)**2
4169 
4170  END IF
4171 
4172 END SUBROUTINE phi_dd_gross_vrabec
4173 
4174 
4175 
4176 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4177 !
4178 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4179 !
4180  SUBROUTINE phi_qq_gross( k, z3_rk, fqq_rk )
4181 !
4182  USE parameters, ONLY: pi, kbol
4183  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
4184  USE eos_constants, ONLY: qqp2, qqp3, qqp4
4185  IMPLICIT NONE
4186 !
4187 ! ----------------------------------------------------------------------
4188  INTEGER, INTENT(IN) :: k
4189  REAL, INTENT(IN) :: z3_rk
4190  REAL, INTENT(IN OUT) :: fqq_rk
4191 !
4192 ! --- local variables---------------------------------------------------
4193  INTEGER :: i, j, l, m
4194 
4195  REAL :: factor2, factor3, z3
4196  REAL :: xijfa, xijkfa, xijfa_x, xijkf_x, eij
4197  REAL :: fqq2, fqq3, fqq2x, fqq3x
4198  REAL, DIMENSION(nc) :: qq2
4199  REAL, DIMENSION(nc,nc) :: iqq2, iqq4, iqq2x, iqq4x
4200  REAL, DIMENSION(nc,nc,nc) :: iqq3, iqq3x
4201 ! ----------------------------------------------------------------------
4202 
4203 
4204  fqq_rk = 0.0
4205  z3 = eta
4206  DO i = 1, ncomp
4207  IF ( uij(i,i) == 0.0 ) write (*,*) 'PHI_QQ_GROSS: do not use dimensionless units'
4208  qq2(i) = (parame(i,7))**2 *1.e-69 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**5 *1.e-50)
4209  END DO
4210 
4211  DO i = 1, ncomp
4212  DO j = 1, ncomp
4213  iqq2(i,j) = 0.0
4214  iqq4(i,j) = 0.0
4215  iqq2x(i,j) = 0.0
4216  iqq4x(i,j) = 0.0
4217  IF (parame(i,7) /= 0.0 .AND. parame(j,7) /= 0.0) THEN
4218  DO m = 0, 4
4219  iqq2(i,j) = iqq2(i,j) + qqp2(i,j,m) * z3**m
4220  iqq4(i,j) = iqq4(i,j) + qqp4(i,j,m) * z3**m
4221  iqq2x(i,j) = iqq2x(i,j) + qqp2(i,j,m) * REAL(m)*z3**(m-1)*z3_rk
4222  iqq4x(i,j) = iqq4x(i,j) + qqp4(i,j,m) * REAL(m)*z3**(m-1)*z3_rk
4223  END DO
4224  DO l = 1, ncomp
4225  iqq3(i,j,l) = 0.0
4226  iqq3x(i,j,l) = 0.0
4227  IF (parame(l,7) /= 0.0) THEN
4228  DO m = 0, 4
4229  iqq3(i,j,l) = iqq3(i,j,l) + qqp3(i,j,l,m)*z3**m
4230  iqq3x(i,j,l) = iqq3x(i,j,l) + qqp3(i,j,l,m)*REAL(m) *z3**(m-1)*z3_rk
4231  END DO
4232  END IF
4233  END DO
4234  END IF
4235  END DO
4236  END DO
4237 
4238  factor2= -9.0/16.0*pi
4239  factor3= 9.0/16.0*pi**2
4240 
4241  fqq2 = 0.0
4242  fqq3 = 0.0
4243  fqq2x = 0.0
4244  fqq3x = 0.0
4245  DO i = 1, ncomp
4246  xijfa_x = 2.0*x(i)*rho*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /t &
4247  *uij(k,k)*qq2(k)*sig_ij(k,k)**5 /t/sig_ij(i,k)**7.0
4248  eij = (parame(i,3)*parame(k,3))**0.5
4249  fqq2x =fqq2x +factor2*xijfa_x*(iqq2(i,k)+eij/t*iqq4(i,k))
4250  DO j=1,ncomp
4251  IF (parame(i,7) /= 0.0 .AND. parame(j,7) /= 0.0) THEN
4252  xijfa =x(i)*rho*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /t &
4253  *x(j)*rho*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /t/sig_ij(i,j)**7.0
4254  eij = (parame(i,3)*parame(j,3))**0.5
4255  fqq2= fqq2 +factor2*xijfa*(iqq2(i,j) +eij/t*iqq4(i,j) )
4256  fqq2x =fqq2x +factor2*xijfa*(iqq2x(i,j)+eij/t*iqq4x(i,j))
4257  ! ------------------
4258  xijkf_x=x(i)*rho*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /t/sig_ij(i,j)**3 &
4259  *x(j)*rho*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /t/sig_ij(i,k)**3 &
4260  *3.0* uij(k,k)*qq2(k)*sig_ij(k,k)**5 /t/sig_ij(j,k)**3
4261  fqq3x = fqq3x + factor3*xijkf_x*iqq3(i,j,k)
4262  DO l = 1, ncomp
4263  IF (parame(l,7) /= 0.0) THEN
4264  xijkfa=x(i)*rho*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /t/sig_ij(i,j)**3 &
4265  *x(j)*rho*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /t/sig_ij(i,l)**3 &
4266  *x(l)*rho*uij(l,l)*qq2(l)*sig_ij(l,l)**5 /t/sig_ij(j,l)**3
4267  fqq3 =fqq3 + factor3 * xijkfa *iqq3(i,j,l)
4268  fqq3x =fqq3x + factor3 * xijkfa *iqq3x(i,j,l)
4269  END IF
4270  END DO
4271  END IF
4272  END DO
4273  END DO
4274 
4275  IF (fqq2 < -1.e-50 .AND. fqq3 /= 0.0 .AND. fqq2x /= 0.0 .AND. fqq3x /= 0.0) THEN
4276  fqq_rk = fqq2* (fqq2*fqq2x - 2.0*fqq3*fqq2x+fqq2*fqq3x) / (fqq2-fqq3)**2
4277  END IF
4278 
4279 END SUBROUTINE phi_qq_gross
4280 
4281 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4282 !
4283 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4284 !
4285  SUBROUTINE phi_dq_vrabec_gross( k, z3_rk, fdq_rk )
4286 !
4287  USE parameters, ONLY: pi, kbol
4288  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
4289  USE eos_constants, ONLY: dqp2, dqp3, dqp4
4290  IMPLICIT NONE
4291 !
4292 ! ----------------------------------------------------------------------
4293  INTEGER, INTENT(IN) :: k
4294  REAL, INTENT(IN) :: z3_rk
4295  REAL, INTENT(IN OUT) :: fdq_rk
4296 !
4297 ! --- local variables---------------------------------------------------
4298  INTEGER :: i, j, l, m
4299 
4300  REAL :: factor2, factor3, z3
4301  REAL :: xijfa, xijkfa, xijfa_x, xijkf_x, eij
4302  REAL :: fdq2, fdq3, fdq2x, fdq3x
4303  REAL, DIMENSION(nc) :: my2dd, myfac, qq2, q_fac
4304  REAL, DIMENSION(nc,nc) :: idq2, idq4, idq2x, idq4x
4305  REAL, DIMENSION(nc,nc,nc) :: idq3, idq3x
4306 ! ----------------------------------------------------------------------
4307 
4308  fdq_rk = 0.0
4309  z3 = eta
4310  DO i=1,ncomp
4311  my2dd(i) = (parame(i,6))**2 *1.e-49 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**3 *1.e-30)
4312  myfac(i) = parame(i,3)/t*parame(i,2)**4 *my2dd(i)
4313  qq2(i) = (parame(i,7))**2 *1.e-69 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**5 *1.e-50)
4314  q_fac(i) = parame(i,3)/t*parame(i,2)**4 *qq2(i)
4315  END DO
4316 
4317  DO i = 1, ncomp
4318  DO j = 1, ncomp
4319  idq2(i,j) = 0.0
4320  idq4(i,j) = 0.0
4321  idq2x(i,j) = 0.0
4322  idq4x(i,j) = 0.0
4323  DO m = 0, 4
4324  idq2(i,j) = idq2(i,j) + dqp2(i,j,m)*z3**m
4325  idq4(i,j) = idq4(i,j) + dqp4(i,j,m)*z3**m
4326  idq2x(i,j) = idq2x(i,j) + dqp2(i,j,m)*REAL(m)*z3**(m-1) *z3_rk
4327  idq4x(i,j) = idq4x(i,j) + dqp4(i,j,m)*REAL(m)*z3**(m-1) *z3_rk
4328  END DO
4329  DO l = 1, ncomp
4330  idq3(i,j,l) = 0.0
4331  idq3x(i,j,l) = 0.0
4332  DO m = 0, 4
4333  idq3(i,j,l) =idq3(i,j,l) +dqp3(i,j,l,m)*z3**m
4334  idq3x(i,j,l)=idq3x(i,j,l)+dqp3(i,j,l,m)*REAL(m)*z3**(m-1)*z3_rk
4335  END DO
4336  END DO
4337  END DO
4338  END DO
4339 
4340  factor2= -9.0/4.0*pi
4341  factor3= pi**2
4342 
4343  fdq2 = 0.0
4344  fdq3 = 0.0
4345  fdq2x = 0.0
4346  fdq3x = 0.0
4347  DO i = 1, ncomp
4348  xijfa_x = x(i)*rho*( myfac(i)*q_fac(k) + myfac(k)*q_fac(i) ) / sig_ij(i,k)**5
4349  eij = (parame(i,3)*parame(k,3))**0.5
4350  fdq2x =fdq2x +factor2*xijfa_x*(idq2(i,k)+eij/t*idq4(i,k))
4351  DO j=1,ncomp
4352  xijfa =x(i)*rho*myfac(i) * x(j)*rho*q_fac(j) /sig_ij(i,j)**5
4353  eij = (parame(i,3)*parame(j,3))**0.5
4354  fdq2= fdq2 +factor2*xijfa*(idq2(i,j) +eij/t*idq4(i,j) )
4355  fdq2x =fdq2x +factor2*xijfa*(idq2x(i,j) +eij/t*idq4x(i,j))
4356  !---------------------
4357  xijkf_x=x(i)*rho*x(j)*rho/(sig_ij(i,j)*sig_ij(i,k)*sig_ij(j,k))**2 &
4358  *( myfac(i)*q_fac(j)*myfac(k) + myfac(i)*q_fac(k)*myfac(j) &
4359  + myfac(k)*q_fac(i)*myfac(j) +myfac(i)*q_fac(j)*q_fac(k)*1.1937350 &
4360  +myfac(i)*q_fac(k)*q_fac(j)*1.193735 &
4361  +myfac(k)*q_fac(i)*q_fac(j)*1.193735 )
4362  fdq3x = fdq3x + factor3*xijkf_x*idq3(i,j,k)
4363  DO l = 1, ncomp
4364  xijkfa=x(i)*rho*x(j)*rho*x(l)*rho/(sig_ij(i,j)*sig_ij(i,l)*sig_ij(j,l))**2 &
4365  *( myfac(i)*q_fac(j)*myfac(l) &
4366  +myfac(i)*q_fac(j)*q_fac(l)*1.193735 )
4367  fdq3 =fdq3 + factor3 * xijkfa *idq3(i,j,l)
4368  fdq3x =fdq3x + factor3 * xijkfa *idq3x(i,j,l)
4369  END DO
4370  END DO
4371  END DO
4372 
4373  IF (fdq2 < -1.e-50 .AND. fdq3 /= 0.0 .AND. fdq2x /= 0.0 .AND. fdq3x /= 0.0)THEN
4374 
4375  fdq_rk = fdq2* (fdq2*fdq2x - 2.0*fdq3*fdq2x+fdq2*fdq3x) / (fdq2-fdq3)**2
4376 
4377  END IF
4378 
4379 END SUBROUTINE phi_dq_vrabec_gross
4380 
4381 
4382 
4383 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4384 !
4385 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4386 !
4387  SUBROUTINE p_numerical
4388 !
4389  USE eos_variables
4390  IMPLICIT NONE
4391 !
4392 !-----local variables-------------------------------------------------
4393  REAL :: dzetdv, eta_0, dist, fact
4394  REAL :: fres1, fres2, fres3, fres4, fres5
4395  REAL :: df_dr, df_drdr, pideal, dpiddz
4396  REAL :: tfr_1, tfr_2, tfr_3, tfr_4, tfr_5
4397 !-----------------------------------------------------------------------
4398 
4399 
4400 IF (eta > 0.1) THEN
4401  fact = 1.0
4402 ELSE IF (eta <= 0.1 .AND. eta > 0.01) THEN
4403  fact = 10.0
4404 ELSE
4405  fact = 10.0
4406 END IF
4407 dist = eta*3.d-3 *fact
4408 ! dist = eta*4.d-3 *fact
4409 !*****************************
4410 ! fuer MC simulation: neues dist:
4411 ! dist = eta*5.d-3*fact
4412 
4413 eta_0 = eta
4414 eta = eta_0 - 2.0*dist
4415 CALL f_numerical
4416 fres1 = fres
4417 tfr_1 = tfr
4418 eta = eta_0 - dist
4419 CALL f_numerical
4420 fres2 = fres
4421 tfr_2 = tfr
4422 eta = eta_0 + dist
4423 CALL f_numerical
4424 fres3 = fres
4425 tfr_3 = tfr
4426 eta = eta_0 + 2.0*dist
4427 CALL f_numerical
4428 fres4 = fres
4429 tfr_4 = tfr
4430 eta = eta_0
4431 CALL f_numerical
4432 fres5 = fres
4433 tfr_5 = tfr
4434 
4435 !---------------------------------------------------------
4436 ! ptfr = (-tfr_4+8.0*tfr_3-8.0*tfr_2+tfr_1)/(12.0*dist)
4437 ! & *dzetdv*(KBOL*T)/1.E-30
4438 ! ztfr =ptfr /( rho * (KBOL*t) / 1.E-30)
4439 ! ptfrdz = (-tfr_4+16.0*tfr_3-3.d1*tfr_5+16.0*tfr_2-tfr_1)
4440 ! & /(12.0*(dist**2 ))* dzetdv*(KBOL*T)/1.E-30
4441 ! & + (-tfr_4+8.0*tfr_3-8.0*tfr_2+tfr_1)
4442 ! & /(12.0*dist) * 2.0 *eta*6.0/PI/D
4443 ! & *(KBOL*T)/1.E-30
4444 ! ztfrdz=ptfrdz/( rho*(kbol*T)/1.E-30 ) - ztfr/eta
4445 ! write (*,*) eta,ztfr,ztfrdz
4446 
4447 ! dtfr_dr = (-tfr_4+8.0*tfr_3-8.0*tfr_2+tfr_1)/(12.0*dist)
4448 ! write (*,*) eta,dtfr_dr
4449 ! stop
4450 !---------------------------------------------------------
4451 
4452 df_dr = (-fres4+8.0*fres3-8.0*fres2+fres1) / (12.0*dist)
4453 df_drdr = (-fres4+16.0*fres3-3.d1*fres5+16.0*fres2-fres1) &
4454  /(12.0*(dist**2 ))
4455 
4456 
4457 dzetdv = eta*rho
4458 
4459 pges = (-fres4+8.0*fres3-8.0*fres2+fres1) &
4460  /(12.0*dist) *dzetdv*(kbol*t)/1.e-30
4461 
4462 dpiddz = 1.0/z3t*(kbol*t)/1.e-30
4463 pgesdz = (-fres4+16.0*fres3-3.d1*fres5+16.0*fres2-fres1) &
4464  /(12.0*(dist**2 ))* dzetdv*(kbol*t)/1.e-30 &
4465  + (-fres4+8.0*fres3-8.0*fres2+fres1) /(12.0*dist) * 2.0 *rho &
4466  *(kbol*t)/1.e-30 + dpiddz
4467 
4468 pgesd2 = (fres4-2.0*fres3+2.0*fres2-fres1) /(2.0*dist**3 ) &
4469  * dzetdv*(kbol*t)/1.e-30 &
4470  + (-fres4+16.0*fres3-3.d1*fres5+16.0*fres2-fres1) /(12.0*(dist**2 )) &
4471  * 4.0 *rho *(kbol*t)/1.e-30 + (-fres4+8.0*fres3-8.0*fres2+fres1) &
4472  /(12.0*dist) * 2.0 /z3t *(kbol*t)/1.e-30
4473 pgesd3 = (fres4-4.0*fres3+6.0*fres5-4.0*fres2+fres1) /(dist**4 ) &
4474  * dzetdv*(kbol*t)/1.e-30 + (fres4-2.0*fres3+2.0*fres2-fres1) &
4475  /(2.0*dist**3 ) * 6.0 *rho *(kbol*t)/1.e-30 &
4476  + (-fres4+16.0*fres3-3.d1*fres5+16.0*fres2-fres1) &
4477  /(12.0*dist**2 )* 6.0 /z3t *(kbol*t)/1.e-30
4478 
4479 !------------------p ideal------------------------------------
4480 pideal = rho * (kbol*t) / 1.e-30
4481 
4482 !------------------p summation, p comes out in Pa ------------
4483 pges = pideal + pges
4484 
4485 END SUBROUTINE p_numerical
4486 
4487 
4488 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4489 !
4490 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4491 !
4492  SUBROUTINE h_numerical
4493 !
4494  USE parameters, ONLY: rgas
4495  USE eos_variables
4496  IMPLICIT NONE
4497 !
4498 !---------------------------------------------------------------------
4499  REAL :: dist, fact, rho_0
4500  REAL :: fres1,fres2,fres3,fres4,fres5
4501  REAL :: f_1, f_2, f_3, f_4
4502  REAL :: cv_res, t_tmp, zges
4503  REAL :: f_dt, f_dtdt, f_dr, f_drdr, f_drdt
4504 !-----------------------------------------------------------------------
4505 
4506 
4507 CALL perturbation_parameter
4508 rho_0 = eta/z3t
4509 
4510 
4511 fact = 1.0
4512 dist = t * 100.e-5 * fact
4513 
4514 t_tmp = t
4515 
4516 t = t_tmp - 2.0*dist
4517 CALL perturbation_parameter
4518 eta = z3t*rho_0
4519 CALL f_numerical
4520 fres1 = fres
4521 t = t_tmp - dist
4522 CALL perturbation_parameter
4523 eta = z3t*rho_0
4524 CALL f_numerical
4525 fres2 = fres
4526 t = t_tmp + dist
4527 CALL perturbation_parameter
4528 eta = z3t*rho_0
4529 CALL f_numerical
4530 fres3 = fres
4531 t = t_tmp + 2.0*dist
4532 CALL perturbation_parameter
4533 eta = z3t*rho_0
4534 CALL f_numerical
4535 fres4 = fres
4536 t = t_tmp
4537 CALL perturbation_parameter
4538 eta = z3t*rho_0
4539 CALL f_numerical
4540 fres5 = fres
4541 ! *(KBOL*T)/1.E-30
4542 
4543 zges = (p * 1.e-30)/(kbol*t*rho_0)
4544 
4545 
4546 f_dt = (-fres4+8.0*fres3-8.0*fres2+fres1)/(12.0*dist)
4547 f_dtdt = (-fres4+16.0*fres3-3.d1*fres5+16.0*fres2-fres1) /(12.0*(dist**2 ))
4548 
4549 s_res = (- f_dt -fres/t)*rgas*t + rgas * log(zges)
4550 h_res = ( - t*f_dt + zges-1.0 ) * rgas*t
4551 cv_res = -( t*f_dtdt + 2.0*f_dt ) * rgas*t
4552 
4553 
4554 
4555 t = t_tmp - 2.0*dist
4556 CALL perturbation_parameter
4557 eta = z3t*rho_0
4558 CALL p_numerical
4559 f_1 = pges/(eta*rho_0*(kbol*t)/1.e-30)
4560 
4561 t = t_tmp - dist
4562 CALL perturbation_parameter
4563 eta = z3t*rho_0
4564 CALL p_numerical
4565 f_2 = pges/(eta*rho_0*(kbol*t)/1.e-30)
4566 
4567 t = t_tmp + dist
4568 CALL perturbation_parameter
4569 eta = z3t*rho_0
4570 CALL p_numerical
4571 f_3 = pges/(eta*rho_0*(kbol*t)/1.e-30)
4572 
4573 t = t_tmp + 2.0*dist
4574 CALL perturbation_parameter
4575 eta = z3t*rho_0
4576 CALL p_numerical
4577 f_4 = pges/(eta*rho_0*(kbol*t)/1.e-30)
4578 
4579 t = t_tmp
4580 CALL perturbation_parameter
4581 eta = z3t*rho_0
4582 CALL p_numerical
4583 
4584 f_dr = pges / (eta*rho_0*(kbol*t)/1.e-30)
4585 f_drdr = pgesdz/ (eta*rho_0*(kbol*t)/1.e-30) - f_dr*2.0/eta - 1.0/eta**2
4586 
4587 f_drdt = ( - f_4 + 8.0*f_3 - 8.0*f_2 + f_1 ) / ( 12.0*dist )
4588 
4589 cp_res = cv_res - rgas + rgas*( zges + eta*t*f_drdt)**2 / (1.0 + 2.0*eta*f_dr + eta**2 *f_drdr)
4590 ! write (*,*) cv_res,cp_res,eta
4591 
4592 
4593 END SUBROUTINE h_numerical
4594 
4595 
4596 
4597 
4598 
4599 
4600 
4601 
4602 
4603 
4604 
4605 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4606 !
4607 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4608 !
4609  SUBROUTINE f_polar ( fdd, fqq, fdq )
4610 !
4611  USE eos_variables, ONLY: ncomp, parame, dd_term, qq_term, dq_term
4612  IMPLICIT NONE
4613 !
4614 ! ----------------------------------------------------------------------
4615  REAL, INTENT(OUT) :: fdd, fqq, fdq
4616 !
4617 ! --- local variables---------------------------------------------------
4618  INTEGER :: dipole
4619  INTEGER :: quadrupole
4620  INTEGER :: dipole_quad
4621 ! ----------------------------------------------------------------------
4622 
4623  fdd = 0.0
4624  fqq = 0.0
4625  fdq = 0.0
4626 
4627  dipole = 0
4628  quadrupole = 0
4629  dipole_quad = 0
4630  IF ( sum( parame(1:ncomp,6) ) /= 0.0 ) dipole = 1
4631  IF ( sum( parame(1:ncomp,7) ) /= 0.0 ) quadrupole = 1
4632  IF ( dipole == 1 .AND. quadrupole == 1 ) dipole_quad = 1
4633 
4634  ! --------------------------------------------------------------------
4635  ! dipole-dipole term
4636  ! --------------------------------------------------------------------
4637  IF (dipole == 1) THEN
4638 
4639  IF (dd_term == 'GV') CALL f_dd_gross_vrabec( fdd )
4640  ! IF (dd_term == 'SF') CALL F_DD_SAAGER_FISCHER( k )
4641  IF (dd_term /= 'GV' .AND. dd_term /= 'SF') write (*,*) 'specify dipole term !'
4642 
4643  ENDIF
4644 
4645  ! --------------------------------------------------------------------
4646  ! quadrupole-quadrupole term
4647  ! --------------------------------------------------------------------
4648  IF (quadrupole == 1) THEN
4649 
4650  !IF (qq_term == 'SF') CALL F_QQ_SAAGER_FISCHER( k )
4651  IF (qq_term == 'JG') CALL f_qq_gross( fqq )
4652  IF (qq_term /= 'JG' .AND. qq_term /= 'SF') write (*,*) 'specify quadrupole term !'
4653 
4654  ENDIF
4655 
4656  ! --------------------------------------------------------------------
4657  ! dipole-quadrupole cross term
4658  ! --------------------------------------------------------------------
4659  IF (dipole_quad == 1) THEN
4660 
4661  IF (dq_term == 'VG') CALL f_dq_vrabec_gross( fdq )
4662  IF (dq_term /= 'VG' ) write (*,*) 'specify DQ-cross term !'
4663 
4664  ENDIF
4665 
4666 END SUBROUTINE f_polar
4667 
4668 
4669 
4670 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4671 ! SUBROUTINE PRESSURE_SPINODAL
4672 !
4673 ! iterates the density until the derivative of pressure 'pges' to
4674 ! density is equal to zero. A Newton-scheme is used for determining
4675 ! the root to the objective function.
4676 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4677 !
4678  SUBROUTINE pressure_spinodal
4679 !
4680  USE basic_variables, ONLY: num
4681  USE eos_variables
4682  IMPLICIT NONE
4683 !
4684 ! ----------------------------------------------------------------------
4685  INTEGER :: i, max_i
4686  REAL :: eta_iteration
4687  REAL :: error, acc_i, delta_eta
4688 ! ----------------------------------------------------------------------
4689 
4690 acc_i = 1.d-6
4691 max_i = 30
4692 
4693 i = 0
4694 eta_iteration = eta_start
4695 
4696 ! ----------------------------------------------------------------------
4697 ! iterate density until p_calc = p
4698 ! ----------------------------------------------------------------------
4699 
4700 error = acc_i + 1.0
4701 DO WHILE ( abs(error) > acc_i .AND. i < max_i )
4702 
4703  i = i + 1
4704  eta = eta_iteration
4705 
4706  IF ( num == 0 ) THEN
4707  CALL p_eos
4708  ELSE IF ( num == 1 ) THEN
4709  CALL p_numerical
4710  ELSE IF ( num == 2 ) THEN
4711  WRITE(*,*) 'CRITICAL RENORM NOT INCLUDED YET'
4712  !!CALL F_EOS_RN
4713  ELSE
4714  write (*,*) 'define calculation option (num)'
4715  END IF
4716 
4717  error = pgesdz
4718 
4719  delta_eta = error/ pgesd2
4720  IF ( delta_eta > 0.02 ) delta_eta = 0.02
4721  IF ( delta_eta < -0.02 ) delta_eta = -0.02
4722 
4723  eta_iteration = eta_iteration - delta_eta
4724  ! write (*,'(a,i3,3G18.10)') 'iter',i, error, eta_iteration, pgesdz
4725 
4726  IF (eta_iteration > 0.9) eta_iteration = 0.5
4727  IF (eta_iteration <= 0.0) eta_iteration = 1.e-16
4728 
4729 END DO
4730 
4731 eta = eta_iteration
4732 
4733 END SUBROUTINE pressure_spinodal
4734 
4735 
4736 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4737 !
4738 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4739 !
4740  SUBROUTINE f_ideal_gas ( fid )
4741 !
4742  USE eos_variables, ONLY: nc, ncomp, t, x, rho, pi, kbol, nav
4743  IMPLICIT NONE
4744 !
4745 !---------------------------------------------------------------------
4746  REAL, INTENT(IN OUT) :: fid
4747 !---------------------------------------------------------------------
4748  INTEGER :: i
4749  REAL, DIMENSION(nc) :: rhoi
4750 !----------------------------------------------------------------------
4751 
4752  !h_Planck = 6.62606896E-34 ! Js
4753  DO i = 1, ncomp
4754  rhoi(i) = x(i) * rho
4755  ! debroglie(i) = h_Planck *1d10 & ! in units Angstrom
4756  ! *SQRT( 1.0 / (2.0*PI *1.0 / NAv / 1000.0 * KBOL*T) )
4757  ! ! *SQRT( 1.0 / (2.0*PI *mm(i) /NAv/1000.0 * KBOL*T) )
4758  ! fid = fid + x(i) * ( LOG(rhoi(i)*debroglie(i)**3) - 1.0 )
4759  fid = fid + x(i) * ( log(rhoi(i)) - 1.0 )
4760  END DO
4761 
4762  END SUBROUTINE f_ideal_gas
4763 
4764 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4765 !
4766 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4767 !
4768  SUBROUTINE f_hard_sphere ( m_mean2, fhs )
4769 !
4770  USE eos_variables, ONLY: z0t, z1t, z2t, z3t, eta, rho
4771  IMPLICIT NONE
4772 !
4773 !---------------------------------------------------------------------
4774  REAL, INTENT(IN) :: m_mean2
4775  REAL, INTENT(IN OUT) :: fhs
4776 !---------------------------------------------------------------------
4777  REAL :: z0, z1, z2, z3, zms
4778 !----------------------------------------------------------------------
4779 
4780  rho = eta / z3t
4781  z0 = z0t * rho
4782  z1 = z1t * rho
4783  z2 = z2t * rho
4784  z3 = z3t * rho
4785  zms = 1.0 - z3
4786 
4787  fhs= m_mean2*( 3.0*z1*z2/zms + z2**3 /z3/zms/zms + (z2**3 /z3/z3-z0)*log(zms) )/z0
4788 
4789 
4790  END SUBROUTINE f_hard_sphere
4791 
4792 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4793 !
4794 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4795 !
4796  SUBROUTINE f_chain_tpt1 ( fhc )
4797 !
4798  USE eos_variables, ONLY: nc, ncomp, mseg, x, z0t, z1t, z2t, z3t, &
4799  rho, eta, dij_ab, gij
4800  IMPLICIT NONE
4801 !
4802 !---------------------------------------------------------------------
4803  REAL, INTENT(IN OUT) :: fhc
4804 !---------------------------------------------------------------------
4805  INTEGER :: i, j
4806  REAL :: z0, z1, z2, z3, zms
4807 !---------------------------------------------------------------------
4808 
4809  rho = eta / z3t
4810  z0 = z0t * rho
4811  z1 = z1t * rho
4812  z2 = z2t * rho
4813  z3 = z3t * rho
4814  zms = 1.0 - z3
4815 
4816  DO i = 1, ncomp
4817  DO j = 1, ncomp
4818  gij(i,j) = 1.0/zms + 3.0*dij_ab(i,j)*z2/zms/zms + 2.0*(dij_ab(i,j)*z2)**2 / zms**3
4819  END DO
4820  END DO
4821 
4822  fhc = 0.0
4823  DO i = 1, ncomp
4824  fhc = fhc + x(i) *(1.0- mseg(i)) *log(gij(i,i))
4825  END DO
4826 
4827  END SUBROUTINE f_chain_tpt1
4828 
4829 
4830 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4831 !
4832 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4833 !
4834  SUBROUTINE f_chain_tpt_d ( fhc )
4835 !
4836  USE eos_variables, ONLY: nc, ncomp, mseg, x, z0t, z1t, z2t, z3t, rho, eta, &
4837  dhs, mseg, dij_ab, gij
4838  IMPLICIT NONE
4839 !
4840 !---------------------------------------------------------------------
4841  REAL, INTENT(OUT) :: fhc
4842 !---------------------------------------------------------------------
4843  INTEGER :: i, j
4844  REAL, DIMENSION(nc) :: gij_hd
4845  REAL :: z0, z1, z2, z3, zms
4846 !---------------------------------------------------------------------
4847 
4848  rho = eta / z3t
4849  z0 = z0t * rho
4850  z1 = z1t * rho
4851  z2 = z2t * rho
4852  z3 = z3t * rho
4853  zms = 1.0 - z3
4854 
4855  DO i = 1, ncomp
4856  DO j = 1, ncomp
4857  gij(i,j) = 1.0/zms + 3.0*dij_ab(i,j)*z2/zms/zms + 2.0*(dij_ab(i,j)*z2)**2 / zms**3
4858  END DO
4859  END DO
4860 
4861  DO i = 1, ncomp
4862  gij_hd(i) = 1.0/(2.0*zms) + 3.0*dij_ab(i,i)*z2 / zms**2
4863  END DO
4864 
4865  fhc = 0.0
4866  DO i = 1, ncomp
4867  IF ( mseg(i) >= 2.0 ) THEN
4868  fhc = fhc - x(i) * ( mseg(i)/2.0 * log( gij(i,i) ) + ( mseg(i)/2.0 - 1.0 ) * log( gij_hd(i)) )
4869  ELSE
4870  fhc = fhc + x(i) * ( 1.0 - mseg(i) ) * log( gij(i,i) )
4871  END IF
4872  END DO
4873 
4874  END SUBROUTINE f_chain_tpt_d
4875 
4876 
4877 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4878 !
4879 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4880 !
4881  SUBROUTINE f_chain_hu_liu ( fhc )
4882 !
4883  USE eos_variables, ONLY: nc, ncomp, mseg, x, rho, eta
4884  IMPLICIT NONE
4885 !
4886 ! This subroutine calculates the hard chain contribution of the TPT-Liu-Hu Eos.
4887 !---------------------------------------------------------------------
4888  REAL, INTENT(OUT) :: fhc
4889 !---------------------------------------------------------------------
4890  REAL :: a2, b2, c2, a3, b3, c3
4891  REAL :: a20, b20, c20, a30, b30, c30
4892  REAL :: sum1, sum2, am, bm, cm
4893  REAL :: zms
4894 !---------------------------------------------------------------------
4895 
4896  zms = 1.0 - eta
4897 
4898  sum1 = sum( x(1:ncomp)*(mseg(1:ncomp)-1.0) )
4899  sum2 = sum( x(1:ncomp)/mseg(1:ncomp)*(mseg(1:ncomp)-1.0)*(mseg(1:ncomp)-2.0) )
4900 
4901  a2 = 0.45696
4902  a3 = -0.74745
4903  b2 = 2.10386
4904  b3 = 3.49695
4905  c2 = 1.75503
4906  c3 = 4.83207
4907  a20 = - a2 + b2 - 3.0*c2
4908  b20 = - a2 - b2 + c2
4909  c20 = c2
4910  a30 = - a3 + b3 - 3.0*c3
4911  b30 = - a3 - b3 + c3
4912  c30 = c3
4913  am = (3.0 + a20) * sum1 + a30 * sum2
4914  bm = (1.0 + b20) * sum1 + b30 * sum2
4915  cm = (1.0 + c20) * sum1 + c30 * sum2
4916 
4917  fhc = - ( (am*eta - bm) / (2.0*zms) + bm/2.0/zms**2 - cm *log(zms) )
4918 
4919 
4920  END SUBROUTINE f_chain_hu_liu
4921 
4922 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4923 !
4924 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4925 !
4926  SUBROUTINE f_chain_hu_liu_rc ( fhs, fhc )
4927 !
4928  USE eos_variables, ONLY: mseg, chir, eta
4929  IMPLICIT NONE
4930 !
4931 ! This subroutine calculates the hard chain contribution of the TPT-Liu-Hu Eos.
4932 !---------------------------------------------------------------------
4933  REAL, INTENT(IN) :: fhs
4934  REAL, INTENT(OUT) :: fhc
4935 !---------------------------------------------------------------------
4936  REAL :: a2, b2, c2, a3, b3, c3
4937  REAL :: para1,para2,para3,para4
4938  REAL :: alh,blh,clh
4939 !---------------------------------------------------------------------
4940 
4941 ! This routine is only for pure components
4942 
4943  a2 = 0.45696
4944  b2 = 2.10386
4945  c2 = 1.75503
4946 
4947  para1 = -0.74745
4948  para2 = 0.299154629727814
4949  para3 = 1.087271036653154
4950  para4 = -0.708979110326831
4951  a3 = para1 + para2*chir(1) + para3*chir(1)**2 + para4*chir(1)**3
4952  b3 = 3.49695 - (3.49695 + 0.317719074806190)*chir(1)
4953  c3 = 4.83207 - (4.83207 - 3.480163780334421)*chir(1)
4954 
4955  alh = mseg(1)*(1.0 + ((mseg(1)-1.0)/mseg(1))*a2 + ((mseg(1)-1.0)/mseg(1))*((mseg(1)-2.0)/mseg(1))*a3 )
4956  blh = mseg(1)*(1.0 + ((mseg(1)-1.0)/mseg(1))*b2 + ((mseg(1)-1.0)/mseg(1))*((mseg(1)-2.0)/mseg(1))*b3 )
4957  clh = mseg(1)*(1.0 + ((mseg(1)-1.0)/mseg(1))*c2 + ((mseg(1)-1.0)/mseg(1))*((mseg(1)-2.0)/mseg(1))*c3 )
4958 
4959  fhc = ((3.0 + alh - blh + 3.0*clh)*eta - (1.0 + alh + blh - clh)) / (2.0*(1.0-eta)) + &
4960  (1.0 + alh + blh - clh) / ( 2.0*(1.0-eta)**2 ) + (clh - 1.0)*log(1.0-eta)
4961 
4962  fhc = fhc - fhs
4963 
4964  END SUBROUTINE f_chain_hu_liu_rc
4965 
4966 
4967 
4968 
4969 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4970 !
4971 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
4972 !
4973  SUBROUTINE f_disp_pcsaft ( fdsp )
4974 !
4975  USE eos_variables, ONLY: pi, rho, eta, z0t, apar, bpar, order1, order2
4976  IMPLICIT NONE
4977 !
4978 !---------------------------------------------------------------------
4979  REAL, INTENT(IN OUT) :: fdsp
4980 !---------------------------------------------------------------------
4981  INTEGER :: m
4982  REAL :: i1, i2, c1_con, z3, zms, m_mean
4983 !---------------------------------------------------------------------
4984 
4985  z3 = eta
4986  zms = 1.0 - eta
4987  m_mean = z0t / ( pi / 6.0 )
4988 
4989  i1 = 0.0
4990  i2 = 0.0
4991  DO m = 0, 6
4992  i1 = i1 + apar(m) * z3**m
4993  i2 = i2 + bpar(m) * z3**m
4994  END DO
4995 
4996  c1_con= 1.0/ ( 1.0 + m_mean*(8.0*z3-2.0*z3**2 )/zms**4 &
4997  + (1.0-m_mean)*( 20.0*z3-27.0*z3**2 +12.0*z3**3 -2.0*z3**4 )/(zms*(2.0-z3))**2 )
4998 
4999  fdsp = -2.0*pi*rho*i1*order1 - pi*rho*c1_con*m_mean*i2*order2
5000 
5001  END SUBROUTINE f_disp_pcsaft
5002 
5003 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5004 !
5005 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5006 !
5007  SUBROUTINE f_disp_cksaft ( fdsp )
5008 !
5009  USE eos_variables, ONLY: nc, ncomp, pi, tau, t, rho, eta, x, z0t, mseg, vij, uij, parame, um
5010  USE eos_constants, ONLY: dnm
5011  IMPLICIT NONE
5012 !
5013 !---------------------------------------------------------------------
5014  REAL, INTENT(IN OUT) :: fdsp
5015 !---------------------------------------------------------------------
5016  INTEGER :: i, j, n, m
5017  REAL :: zmr, nmr, m_mean
5018 !---------------------------------------------------------------------
5019 
5020  m_mean = z0t / ( pi / 6.0 )
5021 
5022  DO i = 1, ncomp
5023  DO j = 1, ncomp
5024  vij(i,j)=(0.5*((parame(i,2)*(1.0-0.12 *exp(-3.0*parame(i,3)/t))**3 )**(1.0/3.0) &
5025  +(parame(j,2)*(1.0-0.12 *exp(-3.0*parame(j,3)/t))**3 )**(1.0/3.0)))**3
5026  END DO
5027  END DO
5028  zmr = 0.0
5029  nmr = 0.0
5030  DO i = 1, ncomp
5031  DO j = 1, ncomp
5032  zmr = zmr + x(i)*x(j)*mseg(i)*mseg(j)*vij(i,j)*uij(i,j)
5033  nmr = nmr + x(i)*x(j)*mseg(i)*mseg(j)*vij(i,j)
5034  END DO
5035  END DO
5036  um = zmr / nmr
5037  fdsp = 0.0
5038  DO n = 1, 4
5039  DO m = 1, 9
5040  fdsp = fdsp + dnm(n,m) * (um/t)**n *(eta/tau)**m
5041  END DO
5042  END DO
5043  fdsp = m_mean * fdsp
5044 
5045 
5046  END SUBROUTINE f_disp_cksaft
5047 
5048 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5049 !
5050 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5051 !
5052  SUBROUTINE f_association ( eps_kij, k_kij, fhb )
5053 !
5054  USE eos_variables, ONLY: nc, nsite, ncomp, t, z0t, z1t, z2t, z3t, rho, eta, x, &
5055  parame, sig_ij, dij_ab, gij, nhb_typ, mx, nhb_no
5056  IMPLICIT NONE
5057 !
5058 !---------------------------------------------------------------------
5059  REAL, INTENT(IN) :: eps_kij, k_kij
5060  REAL, INTENT(IN OUT) :: fhb
5061 !---------------------------------------------------------------------
5062  LOGICAL :: assoc
5063  INTEGER :: i, j, k, l, no, ass_cnt, max_eval
5064  REAL, DIMENSION(nc,nc) :: kap_hb
5065  REAL, DIMENSION(nc,nc,nsite,nsite) :: eps_hb
5066  REAL, DIMENSION(nc,nsite,nc,nsite) :: delta
5067  REAL, DIMENSION(nc,nsite) :: mx_itr
5068  REAL :: err_sum, sum0, amix, tol, ass_s1, ass_s2
5069  REAL :: z0, z1, z2, z3, zms
5070 !---------------------------------------------------------------------
5071 
5072  assoc = .false.
5073  DO i = 1,ncomp
5074  IF (nint(parame(i,12)) /= 0) assoc = .true.
5075  END DO
5076  IF (assoc) THEN
5077 
5078  rho = eta / z3t
5079  z0 = z0t * rho
5080  z1 = z1t * rho
5081  z2 = z2t * rho
5082  z3 = z3t * rho
5083  zms = 1.0 - z3
5084 
5085  DO i = 1, ncomp
5086  DO j = 1, ncomp
5087  gij(i,j) = 1.0/zms + 3.0*dij_ab(i,j)*z2/zms/zms + 2.0*(dij_ab(i,j)*z2)**2 / zms**3
5088  END DO
5089  END DO
5090 
5091 
5092  DO i = 1, ncomp
5093  IF ( nint(parame(i,12)) /= 0 ) THEN
5094  nhb_typ(i) = nint( parame(i,12) )
5095  kap_hb(i,i) = parame(i,13)
5096  no = 0
5097  DO k = 1,nhb_typ(i)
5098  DO l = 1,nhb_typ(i)
5099  eps_hb(i,i,k,l) = parame(i,(14+no))
5100  no = no + 1
5101  END DO
5102  END DO
5103  DO k = 1,nhb_typ(i)
5104  nhb_no(i,k) = parame(i,(14+no))
5105  no = no + 1
5106  END DO
5107  ELSE
5108  nhb_typ(i) = 0
5109  kap_hb(i,i)= 0.0
5110  DO k = 1,nsite
5111  DO l = 1,nsite
5112  eps_hb(i,i,k,l) = 0.0
5113  END DO
5114  END DO
5115  END IF
5116  END DO
5117 
5118  DO i = 1,ncomp
5119  DO j = 1,ncomp
5120  IF ( i /= j .AND. (nhb_typ(i) /= 0.AND.nhb_typ(j) /= 0) ) THEN
5121  ! kap_hb(i,j)= (kap_hb(i,i)+kap_hb(j,j))/2.0
5122  ! kap_hb(i,j)= ( ( kap_hb(i,i)**(1.0/3.0) + kap_hb(j,j)**(1.0/3.0) )/2.0 )**3
5123  kap_hb(i,j) = (kap_hb(i,i)*kap_hb(j,j))**0.5 &
5124  *((parame(i,2)*parame(j,2))**3 )**0.5 &
5125  / (0.5*(parame(i,2)+parame(j,2)))**3
5126  kap_hb(i,j)= kap_hb(i,j)*(1.0-k_kij)
5127  DO k = 1,nhb_typ(i)
5128  DO l = 1,nhb_typ(j)
5129  IF ( k /= l .AND. nhb_typ(i) >= 2 .AND. nhb_typ(j) >= 2 ) THEN
5130  eps_hb(i,j,k,l) = (eps_hb(i,i,k,l)+eps_hb(j,j,l,k))/2.0
5131  ! eps_hb(i,j,k,l) = (eps_hb(i,i,k,l)*eps_hb(j,j,l,k))**0.5
5132  eps_hb(i,j,k,l) = eps_hb(i,j,k,l)*(1.0-eps_kij)
5133  ELSE IF ( nhb_typ(i) == 1 .AND. l > k ) THEN
5134  eps_hb(i,j,k,l) = (eps_hb(i,i,k,k)+eps_hb(j,j,l,k))/2.0
5135  eps_hb(j,i,l,k) = (eps_hb(i,i,k,k)+eps_hb(j,j,l,k))/2.0
5136  eps_hb(i,j,k,l) = eps_hb(i,j,k,l)*(1.0-eps_kij)
5137  eps_hb(j,i,l,k) = eps_hb(j,i,l,k)*(1.0-eps_kij)
5138  END IF
5139  END DO
5140  END DO
5141  END IF
5142  END DO
5143  END DO
5144 
5145 !-----setting the self-association to zero for ionic compounds------
5146  DO i = 1,ncomp
5147  IF ( parame(i,10) /= 0) kap_hb(i,i)=0.0
5148  DO j = 1,ncomp
5149  IF ( parame(i,10) /= 0 .AND. parame(j,10) /= 0 ) kap_hb(i,j) = 0.0
5150  END DO
5151  END DO
5152  ! kap_hb(1,2)=0.050
5153  ! kap_hb(2,1)=0.050
5154  ! eps_hb(2,1,1,1)=465.0
5155  ! eps_hb(1,2,1,1)=465.0
5156  ! nhb_typ(1) = 1
5157  ! nhb_typ(2) = 1
5158  ! nhb_no(1,1)= 1.0
5159  ! nhb_no(2,1)= 1.0
5160 
5161 
5162  DO i = 1, ncomp
5163  DO k = 1, nhb_typ(i)
5164  DO j = 1, ncomp
5165  DO l = 1, nhb_typ(j)
5166  delta(i,k,j,l)=gij(i,j)*kap_hb(i,j)*(exp(eps_hb(i,j,k,l)/t)-1.0) *sig_ij(i,j)**3
5167 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5168 ! IF ((i+j).EQ.3) delta(i,k,j,l)=94.0
5169 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5170  END DO
5171  END DO
5172  IF ( mx(i,k) == 0.0 ) mx(i,k) = 1.0
5173  END DO
5174  END DO
5175 
5176 !------constants for Iteration ---------------------------------------
5177  amix = 0.7
5178  tol = 1.e-10
5179  IF (eta < 0.2) tol = 1.e-11
5180  IF (eta < 0.01) tol = 1.e-14
5181  max_eval = 200
5182 
5183 ! --- Iterate over all components and all sites ------------------------
5184  ass_cnt = 0
5185  iterate_tpt1: DO
5186 
5187  ass_cnt = ass_cnt + 1
5188 
5189  DO i = 1, ncomp
5190  DO k = 1, nhb_typ(i)
5191  sum0 = 0.0
5192  DO j = 1, ncomp
5193  DO l = 1, nhb_typ(j)
5194  sum0 = sum0 + x(j)* mx(j,l)*nhb_no(j,l) *delta(i,k,j,l)
5195  END DO
5196  END DO
5197  mx_itr(i,k) = 1.0 / (1.0 + sum0*rho)
5198  END DO
5199  END DO
5200 
5201  err_sum = 0.0
5202  DO i = 1, ncomp
5203  DO k = 1, nhb_typ(i)
5204  err_sum = err_sum + abs( mx_itr(i,k) - mx(i,k) ) ! / ABS(mx_itr(i,k))
5205  mx(i,k) = mx_itr(i,k) * amix + mx(i,k) * (1.0 - amix)
5206  IF ( mx(i,k) <= 0.0 ) mx(i,k)=1.e-50
5207  IF ( mx(i,k) > 1.0 ) mx(i,k)=1.0
5208  END DO
5209  END DO
5210 
5211  IF ( err_sum <= tol .OR. ass_cnt >= max_eval ) THEN
5212  IF ( ass_cnt >= max_eval ) WRITE(*,*) 'F_NUMERICAL: Max_eval violated = ',err_sum,tol
5213  EXIT iterate_tpt1
5214  END IF
5215 
5216  END DO iterate_tpt1
5217 
5218  DO i = 1, ncomp
5219  ass_s1 = 0.0
5220  ass_s2 = 0.0
5221  DO k = 1, nhb_typ(i)
5222  ass_s1 = ass_s1 + nhb_no(i,k) * ( 1.0 - mx(i,k) )
5223  ass_s2 = ass_s2 + nhb_no(i,k) * log(mx(i,k))
5224  END DO
5225  fhb = fhb + x(i) * ( ass_s2 + ass_s1/2.0 )
5226  END DO
5227 
5228  END IF
5229 
5230  END SUBROUTINE f_association
5231 
5232 
5233 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5234 !
5235 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5236 !
5237  SUBROUTINE f_ion_dipole_tbh ( fhend )
5238 !
5239  USE eos_variables, ONLY: nc, pi, kbol, nav, ncomp, t, rho, eta, x, z0t, parame, uij, sig_ij
5240  IMPLICIT NONE
5241 !
5242 !---------------------------------------------------------------------
5243  REAL, INTENT(IN OUT) :: fhend
5244 !---------------------------------------------------------------------
5245  INTEGER :: i, dipole, ions
5246  REAL :: m_mean
5247  REAL :: fh32, fh2, fh52, fh3
5248  REAL :: e_elem, eps_cc0, rho_sol, dielec
5249  REAL :: polabil, ydd, kappa, x_dipol, x_ions
5250  REAL, DIMENSION(nc) :: my2dd, z_ii, e_cd, x_dd, x_ii
5251  REAL :: sig_c, sig_d, sig_cd, r_s
5252  REAL :: i0cc, i1cc, i2cc, icd, idd
5253  REAL :: iccc, iccd, icdd, iddd
5254 !---------------------------------------------------------------------
5255 
5256 m_mean = z0t / ( pi / 6.0 )
5257 
5258 !----------------Dieletric Constant of Water--------------------------
5259 e_elem = 1.602189246e-19 ! in Unit [Coulomb]
5260 eps_cc0 = 8.854187818e-22 ! in Unit [Coulomb**2 /(J*Angstrom)]
5261 ! Correlation of M. Uematsu and E. U. Frank
5262 ! (Static Dieletric Constant of Water and Steam)
5263 ! valid range of conditions 273,15 K <=T<= 823,15 K
5264 ! and density <= 1150 kg/m3 (i.e. 0 <= p <= 500 MPa)
5265 rho_sol = rho * 18.015 * 1.e27/ nav
5266 rho_sol = rho_sol/1000.0
5267 dielec = 1.0+(7.62571/(t/293.15))*rho_sol +(2.44e2/(t/293.15)-1.41e2 &
5268  + 2.78e1*(t/293.15))*rho_sol**2 &
5269  + (-9.63e1/(t/293.15)+4.18e1*(t/293.15) &
5270  - 1.02e1*(t/293.15)**2 )*rho_sol**3 +(-4.52e1/(t/293.15)**2 &
5271  + 8.46e1/(t/293.15)-3.59e1)*rho_sol**4
5272 
5273 
5274 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5275 
5276 dielec = 1.0
5277 
5278 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5279 
5280 
5281 !----------------Dipole-Ion Term-----------------------------------
5282 dipole = 0
5283 ions = 0
5284 fhend = 0.0
5285 DO i = 1, ncomp
5286  IF ( parame(i,6) /= 0.0 .AND. uij(i,i) /= 0.0 .AND. x(i) > 0.0 ) THEN
5287  my2dd(i) = (parame(i,6))**2 *1.e-49 / (uij(i,i)*kbol*sig_ij(i,i)**3 *1.e-30)
5288  dipole = 1
5289  ELSE
5290  my2dd(i) = 0.0
5291  END IF
5292 
5293  z_ii(i) = parame(i,10)
5294  IF ( z_ii(i) /= 0.0 .AND. uij(i,i) /= 0.0 .AND. x(i) > 0.0 ) THEN
5295  e_cd(i) = ( parame(i,10)*e_elem* 1.e5 / sqrt(1.11265005) )**2 &
5296  / ( uij(i,i)*kbol*sig_ij(i,i)*1.e-10 )
5297  ions = 1
5298  ELSE
5299  e_cd(i) = 0.0
5300  END IF
5301 END DO
5302 
5303 
5304 IF ( dipole == 1 .AND. ions == 1 ) THEN
5305 
5306  ydd = 0.0
5307  kappa = 0.0
5308  x_dipol = 0.0
5309  x_ions = 0.0
5310  polabil = 0.0
5311  DO i = 1, ncomp
5312  ydd = ydd + x(i)*(parame(i,6))**2 *1.e-49/ (kbol*t*1.e-30)
5313  kappa = kappa + x(i) &
5314  *(parame(i,10)*e_elem* 1.e5/sqrt(1.11265005))**2 /(kbol*t*1.e-10)
5315  IF (parame(i,10) /= 0.0) THEN
5316  x_ions = x_ions + x(i)
5317  ELSE
5318  polabil = polabil + 4.0*pi*x(i)*rho*1.4573 *1.e-30 &
5319  / (sig_ij(3,3)**3 *1.e-30)
5320  END IF
5321  IF (parame(i,6) /= 0.0) x_dipol= x_dipol+ x(i)
5322  END DO
5323  ydd = ydd * 4.0/9.0 * pi * rho
5324  kappa = sqrt( 4.0 * pi * rho * kappa )
5325 
5326  fh2 = 0.0
5327  sig_c = 0.0
5328  sig_d = 0.0
5329  DO i=1,ncomp
5330  x_ii(i) = 0.0
5331  x_dd(i) = 0.0
5332  IF(parame(i,10) /= 0.0 .AND. x_ions /= 0.0) x_ii(i) = x(i)/x_ions
5333  IF(parame(i,6) /= 0.0 .AND. x_dipol /= 0.0) x_dd(i) = x(i)/x_dipol
5334  sig_c = sig_c + x_ii(i)*parame(i,2)
5335  sig_d = sig_d + x_dd(i)*parame(i,2)
5336  END DO
5337  sig_cd = 0.5 * (sig_c + sig_d)
5338 
5339  r_s = 0.0
5340  ! DO i=1,ncomp
5341  ! r_s=r_s + rho * x(i) * dhs(i)**3
5342  ! END DO
5343  r_s = eta*6.0 / pi / m_mean
5344 
5345  i0cc = - (1.0 + 0.97743 * r_s + 0.05257*r_s*r_s) &
5346  /(1.0 + 1.43613 * r_s + 0.41580*r_s*r_s)
5347  ! I1cc = - (10.0 - 2.0*z3 + z3*z3) /20.0/(1.0 + 2.0*z3)
5348  i1cc = - (10.0 - 2.0*r_s*pi/6.0 + r_s*r_s*pi/6.0*pi/6.0) &
5349  /20.0/(1.0 + 2.0*r_s*pi/6.0)
5350 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5351  ! I2cc = + (z3-4.0)*(z3*z3+2.0) /24.0/(1.0+2.0*z3)
5352  ! relation of Stell and Lebowitz
5353  i2cc = -0.33331+0.7418*r_s - 1.2047*r_s*r_s &
5354  + 1.6139*r_s**3 - 1.5487*r_s**4 + 0.6626*r_s**5
5355 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5356  icd = (1.0 + 0.79576 *r_s + 0.104556 *r_s*r_s) &
5357  /(1.0 + 0.486704*r_s - 0.0222903*r_s*r_s)
5358  idd = (1.0 + 0.18158*r_s - 0.11467*r_s*r_s) &
5359  /3.0/(1.0 - 0.49303*r_s + 0.06293*r_s*r_s)
5360  iccc= 3.0*(1.0 - 1.05560*r_s + 0.26591*r_s*r_s) &
5361  /2.0/(1.0 + 0.53892*r_s - 0.94236*r_s*r_s)
5362  iccd= 11.0*(1.0 + 2.25642 *r_s + 0.05679 *r_s*r_s) &
5363  /6.0/(1.0 + 2.64178 *r_s + 0.79783 *r_s*r_s)
5364  icdd= 0.94685*(1.0 + 2.97323 *r_s + 3.11931 *r_s*r_s) &
5365  /(1.0 + 2.70186 *r_s + 1.22989 *r_s*r_s)
5366  iddd= 5.0*(1.0 + 1.12754*r_s + 0.56192*r_s*r_s) &
5367  /24.0/(1.0 - 0.05495*r_s + 0.13332*r_s*r_s)
5368 
5369  IF ( sig_c <= 0.0 ) WRITE (*,*) 'error in Henderson ion term'
5370 
5371  fh32= - kappa**3 /(12.0*pi*rho)
5372  fh2 = - 3.0* kappa**2 * ydd*icd /(8.0*pi*rho) / sig_cd &
5373  - kappa**4 *sig_c/(16.0*pi*rho)*i0cc
5374  IF (sig_d /= 0.0) fh2 = fh2 - 27.0* ydd * ydd*idd &
5375  /(8.0*pi*rho) / sig_d**3
5376  fh52= (3.0*kappa**3 * ydd + kappa**5 *sig_c**2 *i1cc) &
5377  /(8.0*pi*rho)
5378  fh3 = - kappa**6 * sig_c**3 /(8.0*pi*rho) *(i2cc-iccc/6.0) &
5379  + kappa**4 * ydd *sig_c/(16.0*pi*rho) &
5380  *( (6.0+5.0/3.0*sig_d/sig_c)*i0cc + 3.0*sig_d/sig_c*iccd ) &
5381  + 3.0*kappa**2 * ydd*ydd /(8.0*pi*rho) / sig_cd &
5382  *( (2.0-3.21555*sig_d/sig_cd)*icd +3.0*sig_d/sig_cd*icdd )
5383  IF (sig_d /= 0.0) fh3 = fh3 + 27.0*ydd**3 &
5384  /(16.0*pi*rho)/sig_d**3 *iddd
5385 
5386  fhend = ( fh32 + (fh32*fh32*fh3-2.0*fh32*fh2*fh52+fh2**3 ) &
5387  /(fh2*fh2-fh32*fh52) ) &
5388  / ( 1.0 + (fh32*fh3-fh2*fh52) /(fh2*fh2-fh32*fh52) &
5389  - (fh2*fh3-fh52*fh52) /(fh2*fh2-fh32*fh52) )
5390 !----------
5391 ! fH32= - kappa**3 /(12.0*PI*rho)
5392 ! fH2 = - 3.0* kappa**2 * ydd*Icd /(8.0*PI*rho) / sig_cd
5393 ! fH52= (3.0*kappa**3 * ydd)/(8.0*PI*rho)
5394 ! fH3 = + kappa**4 * ydd *sig_c/(16.0*PI*rho) &
5395 ! *( (6.0+5.0/3.0*sig_d/sig_c)*0.0*I0cc + 3.0*sig_d/sig_c*Iccd) &
5396 ! + 3.0*kappa**2 * ydd*ydd /(8.0*PI*rho) / sig_cd &
5397 ! *( (2.0-3.215550*sig_d/sig_cd)*Icd +3.0*sig_d/sig_cd*Icdd )
5398 
5399 ! fHcd = ( + (fH32*fH32*fH3-2.0*fH32*fH2*fH52+fH2**3 ) &
5400 ! /(fH2*fH2-fH32*fH52) ) &
5401 ! / ( 1.0 + (fH32*fH3-fH2*fH52) /(fH2*fH2-fH32*fH52) &
5402 ! - (fH2*fH3-fH52*fH52) /(fH2*fH2-fH32*fH52) )
5403 
5404 END IF
5405 
5406  END SUBROUTINE f_ion_dipole_tbh
5407 
5408 
5409 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5410 !
5411 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5412 !
5413  SUBROUTINE f_ion_ion_primmsa ( fcc )
5414 !
5415  USE eos_variables, ONLY: nc, pi, kbol, nav, ncomp, t, rho, x, parame, mx
5416  IMPLICIT NONE
5417 !
5418 !---------------------------------------------------------------------
5419  REAL, INTENT(IN OUT) :: fcc
5420 !---------------------------------------------------------------------
5421  INTEGER :: i, j, cc_it, ions
5422  REAL :: e_elem, eps_cc0, rho_sol, dielec
5423  REAL :: x_ions
5424  REAL :: cc_sig1, cc_sig2, cc_sig3
5425  REAL, DIMENSION(nc) :: z_ii, x_ii, sigm_i, my2dd
5426  REAL :: alpha_2, kappa, ii_par
5427  REAL :: cc_omeg, p_n, q2_i, cc_q2, cc_gam
5428  REAL :: cc_error(2), cc_delt
5429  REAL :: rhs, lambda, lam_s
5430 !---------------------------------------------------------------------
5431 
5432 !----------------Dieletric Constant of Water--------------------------
5433 e_elem = 1.602189246e-19 ! in Unit [Coulomb]
5434 eps_cc0 = 8.854187818e-22 ! in Unit [Coulomb**2 /(J*Angstrom)]
5435 ! Correlation of M. Uematsu and E. U. Frank
5436 ! (Static Dieletric Constant of Water and Steam)
5437 ! valid range of conditions 273,15 K <=T<= 823,15 K
5438 ! and density <= 1150 kg/m3 (i.e. 0 <= p <= 500 MPa)
5439 rho_sol = rho * 18.015 * 1.e27/ nav
5440 rho_sol = rho_sol/1000.0
5441 dielec = 1.0+(7.62571/(t/293.15))*rho_sol +(2.44e2/(t/293.15)-1.41e2 &
5442  +2.78e1*(t/293.15))*rho_sol**2 &
5443  +(-9.63e1/(t/293.15)+4.18e1*(t/293.15) &
5444  -1.02e1*(t/293.15)**2 )*rho_sol**3 +(-4.52e1/(t/293.15)**2 &
5445  +8.46e1/(t/293.15)-3.59e1)*rho_sol**4
5446 
5447 
5448 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5449 
5450 dielec = 1.0
5451 
5452 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5453 
5454 
5455 !----------------Ion-Ion: primitive MSA -------------------------------
5456 ! the (dipole moment)**2 [my**2] corresponds to an attraction from
5457 ! point charges of [ SUM(xi * zi**2 * e_elem**2) * 3 * di**2 ]
5458 
5459 ! parame(ion,6))**2 * 1.E-49 / (kbol*T)
5460 ! = (e_elem* 1.E5/SQRT(1.112650050))**2
5461 ! *x(i)*zi**2 *3.0*sig_ij(1,1)**2 *1.E-20
5462 
5463 ! parame(ion,6))**2 = (e_elem* 1.E5/SQRT(1.112650050))**2 /1.E-49
5464 ! *x(i)*zi**2 *3.0*sig_ij(i,i)**2 *1.E-20
5465 
5466 ! with the units
5467 ! my**2 [=] D**2 = 1.E-49 J*m3
5468 ! e_elem **2 [=] C**2 = 1.E5 / SQRT(1.112650050) J*m
5469 
5470 
5471 ions = 0
5472 x_ions = 0.0
5473 fcc = 0.0
5474 DO i = 1, ncomp
5475  z_ii(i) = parame(i,10)
5476  IF (z_ii(i) /= 0.0) THEN
5477  sigm_i(i) = parame(i,2)
5478  ELSE
5479  sigm_i(i) = 0.0
5480  END IF
5481  IF (z_ii(i) /= 0.0) ions = 1
5482  IF (z_ii(i) /= 0.0) x_ions = x_ions + x(i)
5483 END DO
5484 
5485 IF (ions == 1 .AND. x_ions > 0.0) THEN
5486 
5487  cc_sig1 = 0.0
5488  cc_sig2 = 0.0
5489  cc_sig3 = 0.0
5490  DO i=1,ncomp
5491  IF (z_ii(i) /= 0.0) THEN
5492  x_ii(i) = x(i)/x_ions
5493  ELSE
5494  x_ii(i) =0.0
5495  END IF
5496  cc_sig1 = cc_sig1 +x_ii(i)*sigm_i(i)
5497  cc_sig2 = cc_sig2 +x_ii(i)*sigm_i(i)**2
5498  cc_sig3 = cc_sig3 +x_ii(i)*sigm_i(i)**3
5499  END DO
5500 
5501 
5502  ! alpha_2 = 4.0*PI*e_elem**2 /eps_cc0/dielec/kbol/T
5503  alpha_2 = e_elem**2 /eps_cc0 / dielec / kbol/t
5504  kappa = 0.0
5505  DO i = 1, ncomp
5506  kappa = kappa + x(i)*z_ii(i)*z_ii(i)*mx(i,1)
5507  END DO
5508  kappa = sqrt( rho * alpha_2 * kappa )
5509  ii_par= kappa * cc_sig1
5510 
5511  ! Temporaer: nach der Arbeit von Krienke verifiziert
5512  ! noch nicht fuer Mischungen mit unterschiedl. Ladung erweitert
5513  ! ii_par = DSQRT( e_elem**2 /eps_cc0/dielec/kbol/T &
5514  ! *rho*(x(1)*Z_ii(1)**2 + x(2)*Z_ii(2)**2 ) )*cc_sig1
5515 
5516 
5517  cc_gam = kappa/2.0
5518 
5519  ! noch offen !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5520  cc_delt = 0.0
5521  DO i = 1, ncomp
5522  cc_delt = cc_delt + x(i)*mx(i,1)*rho*sigm_i(i)**3
5523  END DO
5524  cc_delt= 1.0 - pi/6.0*cc_delt
5525 
5526  cc_it = 0
5527  13 CONTINUE
5528  j = 0
5529  cc_it = cc_it + 1
5530  131 CONTINUE
5531  j = j + 1
5532  cc_omeg = 0.0
5533  DO i = 1, ncomp
5534  cc_omeg = cc_omeg +x(i)*mx(i,1)*sigm_i(i)**3 /(1.0+cc_gam*sigm_i(i))
5535  END DO
5536  cc_omeg = 1.0 + pi/2.0 / cc_delt * rho * cc_omeg
5537  p_n = 0.0
5538  DO i = 1, ncomp
5539  p_n = p_n + x(i)*mx(i,1)*rho / cc_omeg*sigm_i(i)*z_ii(i) / (1.0+cc_gam*sigm_i(i))
5540  END DO
5541  q2_i = 0.0
5542  cc_q2= 0.0
5543  DO i = 1, ncomp
5544  q2_i = q2_i + rho*x(i)*mx(i,1)*( (z_ii(i)-pi/2.0/cc_delt*sigm_i(i)**2 *p_n) &
5545  /(1.0+cc_gam*sigm_i(i)) )**2
5546  cc_q2 = cc_q2 + x(i)*mx(i,1)*rho*z_ii(i)**2 / (1.0+cc_gam*sigm_i(i))
5547  END DO
5548  q2_i = q2_i*alpha_2 / 4.0
5549 
5550  cc_error(j) = cc_gam - sqrt(q2_i)
5551  IF (j == 1) cc_gam = cc_gam*1.000001
5552  IF (j == 2) cc_gam = cc_gam - cc_error(2)* (cc_gam-cc_gam/1.000001)/(cc_error(2)-cc_error(1))
5553 
5554  IF ( j == 1 .AND. abs(cc_error(1)) > 1.e-15 ) GO TO 131
5555  IF ( cc_it >= 10 ) THEN
5556  WRITE (*,*) ' cc error'
5557  stop
5558  END IF
5559  IF ( j /= 1 ) GO TO 13
5560 
5561  fcc= - alpha_2 / pi/4.0 /rho* (cc_gam*cc_q2 &
5562  + pi/2.0/cc_delt *cc_omeg*p_n**2 ) + cc_gam**3 /pi/3.0/rho
5563  ! Restricted Primitive Model
5564  ! fcc=-(3.0*ii_par*ii_par+6.0*ii_par+2.0 &
5565  ! -2.0*(1.0+2.0*ii_par)**1.50) &
5566  ! /(12.0*PI*rho *cc_sig1**3 )
5567 
5568  ! fcc = x_ions * fcc
5569 
5570  my2dd(3) = (parame(3,6))**2 *1.e-19 /(kbol*t)
5571  my2dd(3) = (1.84)**2 *1.e-19 /(kbol*t)
5572 
5573  rhs = 12.0 * pi * rho * x(3) * my2dd(3)
5574  lam_s = 1.0
5575  12 CONTINUE
5576  lambda = (rhs/((lam_s+2.0)**2 ) + 16.0/((1.0+lam_s)**4 ) )**0.5
5577  IF ( abs(lam_s-lambda) > 1.e-10 )THEN
5578  lam_s = ( lambda + lam_s ) / 2.0
5579  GO TO 12
5580  END IF
5581 
5582  ! f_cd = -(ii_par*ii_par)/(4.0*PI*rho*m_mean *cc_sig1**3 ) &
5583  ! *(dielec-1.0)/(1.0 + parame(3,2)/cc_sig1/lambda)
5584  ! write (*,*) ' ',f_cd,fcc,x_ions
5585  ! f_cd = f_cd/(1.0 - fcc/f_cd)
5586  ! fcc = 0.0
5587 
5588 END IF
5589 
5590 
5591 END SUBROUTINE f_ion_ion_primmsa
5592 
5593 
5594 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5595 !
5596 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5597 !
5598  SUBROUTINE f_ion_ion_nonprimmsa ( fdd, fqq, fdq, fcc )
5599 !
5600  USE eos_variables, ONLY: nc, ncomp, t, eta, x, parame, mseg
5601  IMPLICIT NONE
5602 !
5603 !---------------------------------------------------------------------
5604  REAL, INTENT(IN OUT) :: fdd, fqq, fdq, fcc
5605 !---------------------------------------------------------------------
5606  INTEGER :: dipole
5607  !REAL :: A_MSA !, A_CC, A_CD, A_DD, U_MSA, chempot
5608  REAL, DIMENSION(nc) :: x_export, msegm
5609 !---------------------------------------------------------------------
5610 
5611  dipole = 0
5612  IF ( sum( parame(1:ncomp,6) ) > 1.e-5 ) dipole = 1
5613 
5614  IF ( dipole /= 0 ) THEN ! alternatively ions and dipoles = 1
5615  fdd = 0.0
5616  fqq = 0.0
5617  fdq = 0.0
5618  fcc = 0.0
5619  msegm(:) = mseg(:) ! the entries of the vector mseg and x are changed
5620  x_export(:) = x(:) ! in SEMIRESTRICTED because the ions should be positioned first
5621  ! that is why dummy vectors msegm and x_export are defined
5622  !CALL SEMIRESTRICTED (A_MSA,A_CC,A_CD,A_DD,U_MSA, &
5623  ! chempot,ncomp,parame,t,eta,x_export,msegm,0)
5624  !fdd = A_MSA
5625  write (*,*) 'why are individual contrib. A_CC,A_CD,A_DD not used'
5626  stop
5627  END IF
5628 
5629  END SUBROUTINE f_ion_ion_nonprimmsa
5630 
5631 
5632 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5633 !
5634 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5635 !
5636  SUBROUTINE f_lc_mayersaupe ( flc )
5637 !
5638  USE eos_variables, ONLY: nc, pi, kbol, nav, ncomp, phas, t, rho, eta, &
5639  x, mseg, parame, e_lc, s_lc, dhs
5640  IMPLICIT NONE
5641 !
5642 !---------------------------------------------------------------------
5643  REAL, INTENT(IN OUT) :: flc
5644 !---------------------------------------------------------------------
5645  INTEGER :: i, j, k
5646  INTEGER :: liq_crystal, count_lc, steps_lc
5647  REAL :: alpha_lc, tolerance, deltay
5648  REAL :: integrand1, integrand2, accel_lc
5649  REAL :: error_lc, u_term, sphase
5650  REAL, DIMENSION(nc) :: z_lc, s_lc1, s_lc2, sumu
5651  REAL, DIMENSION(nc,nc) :: u_lc, klc
5652 !---------------------------------------------------------------------
5653 INTEGER :: stabil
5654 COMMON /stabil / stabil
5655 !---------------------------------------------------------------------
5656 
5657 
5658  klc(1,2) = 0.0
5659  klc(2,1) = klc(1,2)
5660 
5661  alpha_lc = 1.0
5662  accel_lc = 4.0
5663  IF ( eta < 0.35 ) accel_lc = 1.3
5664  IF ( eta < 0.15 ) accel_lc = 1.0
5665 
5666  liq_crystal = 0
5667  DO i = 1, ncomp
5668  DO j = 1, ncomp
5669  e_lc(i,j) = (e_lc(i,i)*e_lc(j,j))**0.5 *(1.0-klc(i,j)) !combining rule
5670  ! E_LC(i,j)= ( E_LC(i,i)+E_LC(j,j) ) * 0.5 !combining rule
5671  ! S_LC(i,j)= ( S_LC(i,i)+S_LC(j,j) ) * 0.5 !combining rule
5672  IF (e_lc(i,j) /= 0.0) liq_crystal = 1
5673  END DO
5674  END DO
5675  ! S_LC(1,2) = 0.0
5676  ! S_LC(2,1) = S_LC(1,2)
5677  ! E_LC(1,2) = 60.0
5678  ! E_LC(2,1) = E_LC(1,2)
5679 
5680  IF ( liq_crystal == 1 .AND. phas == 1 .AND. stabil == 0 ) THEN
5681 
5682  count_lc = 0
5683  tolerance = 1.e-6
5684 
5685  steps_lc = 200
5686  deltay = 1.0 / REAL(steps_lc)
5687 
5688  ! --- dimensionless function U_LC repres. anisotr. intermolecular interactions in l.c.
5689 
5690  DO i = 1, ncomp
5691  DO j = 1, ncomp
5692  u_lc(i,j) = 2.0/3.0*pi*mseg(i)*mseg(j) *(0.5*(dhs(i)+dhs(j)))**3 & ! sig_ij(i,j)**3
5693  *(e_lc(i,j)/t+s_lc(i,j))*rho
5694  END DO
5695  END DO
5696 
5697 
5698  DO i=1,ncomp
5699  ! S_lc2(i) = 0.0 !for isotropic
5700  s_lc2(i) = 0.5 !for nematic
5701  s_lc1(i) = s_lc2(i)
5702  END DO
5703 
5704  1 CONTINUE
5705 
5706  DO i = 1, ncomp
5707  IF (s_lc2(i) <= 0.3) s_lc1(i) = s_lc2(i)
5708  IF (s_lc2(i) > 0.3) s_lc1(i) = s_lc1(i) + (s_lc2(i)-s_lc1(i))*accel_lc
5709  END DO
5710 
5711  count_lc = count_lc + 1
5712 
5713  ! --- single-particle orientation partition function Z_LC in liquid crystals
5714 
5715  DO i = 1, ncomp
5716  sumu(i) = 0.0
5717  DO j = 1, ncomp
5718  sumu(i) = sumu(i) + x(j)*u_lc(i,j)*s_lc1(j)
5719  END DO
5720  END DO
5721 
5722  DO i = 1, ncomp
5723  z_lc(i) = 0.0
5724  integrand1 = exp(-0.5*sumu(i)) !eq. for Z_LC with y=0
5725  DO k = 1, steps_lc
5726  integrand2 = exp(0.5*sumu(i)*(3.0*(deltay*REAL(k)) **2 -1.0))
5727  z_lc(i) = z_lc(i) + (integrand1 + integrand2)/2.0*deltay
5728  integrand1 = integrand2
5729  END DO !k-index integration
5730  END DO !i-index Z_LC(i) calculation
5731 
5732  ! --- order parameter S_lc in liquid crystals -----------------------
5733 
5734  error_lc = 0.0
5735  DO i = 1, ncomp
5736  s_lc2(i) = 0.0
5737  integrand1 = -1.0/z_lc(i)*0.5*exp(-0.5*sumu(i)) !for S_lc with y=0
5738  DO k = 1, steps_lc
5739  integrand2 = 1.0/z_lc(i)*0.5*(3.0*(deltay*REAL(k)) &
5740  **2 -1.0)*exp(0.5*sumu(i)*(3.0 *(deltay*REAL(k))**2 -1.0))
5741  s_lc2(i) = s_lc2(i) + (integrand1 + integrand2)/2.0*deltay
5742  integrand1 = integrand2
5743  END DO !k-index integration
5744  error_lc = error_lc + abs(s_lc2(i)-s_lc1(i))
5745  END DO !i-index Z_LC(i) calculation
5746 
5747  sphase = 0.0
5748  DO i = 1, ncomp
5749  sphase = sphase + s_lc2(i)
5750  END DO
5751  IF (sphase < 1.e-4) THEN
5752  error_lc = 0.0
5753  DO i = 1, ncomp
5754  s_lc2(i)= 0.0
5755  z_lc(i) = 1.0
5756  END DO
5757  END IF
5758 
5759 
5760  ! write (*,*) count_LC,S_lc2(1)-S_lc1(1),S_lc2(2)-S_lc1(2)
5761  IF (error_lc > tolerance .AND. count_lc < 400) GO TO 1
5762  ! write (*,*) 'done',eta,S_lc2(1),S_lc2(2)
5763 
5764  IF (count_lc == 400) WRITE (*,*) 'LC iteration not converg.'
5765 
5766  ! --- the anisotropic contribution to the Helmholtz energy ----------
5767 
5768  u_term = 0.0
5769  DO i = 1, ncomp
5770  DO j = 1, ncomp
5771  u_term = u_term + 0.5*x(i)*x(j)*s_lc2(i) *s_lc2(j)*u_lc(i,j)
5772  END DO
5773  END DO
5774 
5775  flc = 0.0
5776  DO i = 1, ncomp
5777  IF (z_lc(i) /= 0.0) flc = flc - x(i) * log(z_lc(i))
5778  END DO
5779  flc = flc + u_term
5780  ! pause
5781 
5782  END IF
5783  ! write (*,'(i2,i2,4(f15.8))') phas,stabil,flc,eta,S_lc2(1),x(1)
5784 
5785 
5786  END SUBROUTINE f_lc_mayersaupe
5787 
5788 
5789 
5790 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5791 !
5792 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5793 !
5794  SUBROUTINE p_polar ( zdd, zddz, zddz2, zddz3, zqq, zqqz, zqqz2, zqqz3, zdq, zdqz, zdqz2, zdqz3 )
5795 !
5796  USE eos_variables, ONLY: ncomp, parame, dd_term, qq_term, dq_term
5797  IMPLICIT NONE
5798 !
5799 ! ----------------------------------------------------------------------
5800  REAL, INTENT(OUT) :: zdd, zddz, zddz2, zddz3
5801  REAL, INTENT(OUT) :: zqq, zqqz, zqqz2, zqqz3
5802  REAL, INTENT(OUT) :: zdq, zdqz, zdqz2, zdqz3
5803 !
5804 ! --- local variables---------------------------------------------------
5805  INTEGER :: dipole
5806  INTEGER :: quadrupole
5807  INTEGER :: dipole_quad
5808 ! ----------------------------------------------------------------------
5809 
5810  zdd = 0.0
5811  zddz = 0.0
5812  zddz2 = 0.0
5813  zddz3 = 0.0
5814  zqq = 0.0
5815  zqqz = 0.0
5816  zqqz2 = 0.0
5817  zqqz3 = 0.0
5818  zdq = 0.0
5819  zdqz = 0.0
5820  zdqz2 = 0.0
5821  zdqz3 = 0.0
5822 
5823  dipole = 0
5824  quadrupole = 0
5825  dipole_quad = 0
5826  IF ( sum( parame(1:ncomp,6) ) /= 0.0 ) dipole = 1
5827  IF ( sum( parame(1:ncomp,7) ) /= 0.0 ) quadrupole = 1
5828  IF ( dipole == 1 .AND. quadrupole == 1 ) dipole_quad = 1
5829 
5830  ! --------------------------------------------------------------------
5831  ! dipole-dipole term
5832  ! --------------------------------------------------------------------
5833  IF (dipole == 1) THEN
5834 
5835  IF (dd_term == 'GV') CALL p_dd_gross_vrabec( zdd, zddz, zddz2, zddz3 )
5836  ! IF (dd_term == 'SF') CALL F_DD_SAAGER_FISCHER( k )
5837  IF (dd_term /= 'GV' .AND. dd_term /= 'SF') write (*,*) 'specify dipole term !'
5838 
5839  ENDIF
5840 
5841  ! --------------------------------------------------------------------
5842  ! quadrupole-quadrupole term
5843  ! --------------------------------------------------------------------
5844  IF (quadrupole == 1) THEN
5845 
5846  !IF (qq_term == 'SF') CALL F_QQ_SAAGER_FISCHER( k )
5847  IF (qq_term == 'JG') CALL p_qq_gross( zqq, zqqz, zqqz2, zqqz3 )
5848  IF (qq_term /= 'JG' .AND. qq_term /= 'SF') write (*,*) 'specify quadrupole term !'
5849 
5850  ENDIF
5851 
5852  ! --------------------------------------------------------------------
5853  ! dipole-quadrupole cross term
5854  ! --------------------------------------------------------------------
5855  IF (dipole_quad == 1) THEN
5856 
5857  IF (dq_term == 'VG') CALL p_dq_vrabec_gross( zdq, zdqz, zdqz2, zdqz3 )
5858  IF (dq_term /= 'VG' ) write (*,*) 'specify DQ-cross term !'
5859 
5860  ENDIF
5861 
5862 END SUBROUTINE p_polar
5863 
5864 
5865 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5866 !
5867 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
5868 !
5869  SUBROUTINE p_dd_gross_vrabec( zdd, zddz, zddz2, zddz3 )
5870 !
5871  USE parameters, ONLY: pi, kbol
5872  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
5873  USE eos_constants, ONLY: ddp2, ddp3, ddp4
5874  IMPLICIT NONE
5875 !
5876 ! ----------------------------------------------------------------------
5877  REAL, INTENT(IN OUT) :: zdd, zddz, zddz2, zddz3
5878 ! ----------------------------------------------------------------------
5879  INTEGER :: i, j, k, m
5880  REAL :: factor2, factor3, z3
5881  REAL :: xijfa, xijkfa, eij
5882  REAL :: fdddr, fddd2, fddd3, fddd4
5883  REAL :: fdd2, fdd2z, fdd2z2, fdd2z3, fdd2z4
5884  REAL :: fdd3, fdd3z, fdd3z2, fdd3z3, fdd3z4
5885  REAL, DIMENSION(nc) :: my2dd
5886  REAL, DIMENSION(nc,nc) :: idd2, idd2z, idd2z2, idd2z3, idd2z4
5887  REAL, DIMENSION(nc,nc) :: idd4, idd4z, idd4z2, idd4z3, idd4z4
5888  REAL, DIMENSION(nc,nc,nc) :: idd3, idd3z, idd3z2, idd3z3, idd3z4
5889 ! ----------------------------------------------------------------------
5890 
5891 
5892  zdd = 0.0
5893  zddz = 0.0
5894  zddz2 = 0.0
5895  zddz3 = 0.0
5896  z3 = eta
5897  DO i = 1, ncomp
5898  my2dd(i) = (parame(i,6))**2 *1.e-49 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**3 *1.e-30)
5899  END DO
5900 
5901  DO i = 1, ncomp
5902  DO j = 1, ncomp
5903  idd2(i,j) = 0.0
5904  idd4(i,j) = 0.0
5905  idd2z(i,j) = 0.0
5906  idd4z(i,j) = 0.0
5907  idd2z2(i,j) = 0.0
5908  idd4z2(i,j) = 0.0
5909  idd2z3(i,j) = 0.0
5910  idd4z3(i,j) = 0.0
5911  idd2z4(i,j) = 0.0
5912  idd4z4(i,j) = 0.0
5913  ! IF (paramei,6).NE.0.0 .AND. parame(j,6).NE.0.0) THEN
5914  DO m = 0, 4
5915  idd2(i,j) =idd2(i,j) + ddp2(i,j,m) *z3**(m+1)
5916  idd4(i,j) =idd4(i,j) + ddp4(i,j,m) *z3**(m+1)
5917  idd2z(i,j) =idd2z(i,j) +ddp2(i,j,m)*REAL(m+1) *z3**m
5918  idd4z(i,j) =idd4z(i,j) +ddp4(i,j,m)*REAL(m+1) *z3**m
5919  idd2z2(i,j)=idd2z2(i,j)+ddp2(i,j,m)*REAL((m+1)*m) *z3**(m-1)
5920  idd4z2(i,j)=idd4z2(i,j)+ddp4(i,j,m)*REAL((m+1)*m) *z3**(m-1)
5921  idd2z3(i,j)=idd2z3(i,j)+ddp2(i,j,m)*REAL((m+1)*m*(m-1)) *z3**(m-2)
5922  idd4z3(i,j)=idd4z3(i,j)+ddp4(i,j,m)*REAL((m+1)*m*(m-1)) *z3**(m-2)
5923  idd2z4(i,j)=idd2z4(i,j)+ddp2(i,j,m)*REAL((m+1)*m*(m-1)*(m-2)) *z3**(m-3)
5924  idd4z4(i,j)=idd4z4(i,j)+ddp4(i,j,m)*REAL((m+1)*m*(m-1)*(m-2)) *z3**(m-3)
5925  END DO
5926  DO k = 1, ncomp
5927  idd3(i,j,k) = 0.0
5928  idd3z(i,j,k) = 0.0
5929  idd3z2(i,j,k) = 0.0
5930  idd3z3(i,j,k) = 0.0
5931  idd3z4(i,j,k) = 0.0
5932  ! IF (parame(k,6).NE.0.0) THEN
5933  DO m = 0, 4
5934  idd3(i,j,k) =idd3(i,j,k) +ddp3(i,j,k,m)*z3**(m+2)
5935  idd3z(i,j,k) =idd3z(i,j,k) +ddp3(i,j,k,m)*REAL(m+2)*z3**(m+1)
5936  idd3z2(i,j,k)=idd3z2(i,j,k)+ddp3(i,j,k,m)*REAL((m+2)*(m+1))*z3**m
5937  idd3z3(i,j,k)=idd3z3(i,j,k)+ddp3(i,j,k,m)*REAL((m+2)*(m+1)*m)*z3**(m-1)
5938  idd3z4(i,j,k)=idd3z4(i,j,k)+ddp3(i,j,k,m)*REAL((m+2)*(m+1)*m*(m-1)) *z3**(m-2)
5939  END DO
5940  ! ENDIF
5941  END DO
5942  ! ENDIF
5943  END DO
5944  END DO
5945 
5946  factor2= -pi *rho/z3
5947  factor3= -4.0/3.0*pi**2 * (rho/z3)**2
5948 
5949  fdd2 = 0.0
5950  fdd2z = 0.0
5951  fdd2z2 = 0.0
5952  fdd2z3 = 0.0
5953  fdd2z4 = 0.0
5954  fdd3 = 0.0
5955  fdd3z = 0.0
5956  fdd3z2 = 0.0
5957  fdd3z3 = 0.0
5958  fdd3z4 = 0.0
5959  DO i = 1, ncomp
5960  DO j = 1, ncomp
5961  ! IF (parame(i,6).NE.0.0 .AND. parame(j,6).NE.0.0) THEN
5962  xijfa = x(i)*parame(i,3)/t*parame(i,2)**3 *x(j)*parame(j,3)/t*parame(j,2)**3 &
5963  / ((parame(i,2)+parame(j,2))/2.0)**3 *my2dd(i)*my2dd(j)
5964  eij = (parame(i,3)*parame(j,3))**0.5
5965  fdd2 = fdd2 +factor2*xijfa*(idd2(i,j) +eij/t*idd4(i,j))
5966  fdd2z = fdd2z +factor2*xijfa*(idd2z(i,j) +eij/t*idd4z(i,j))
5967  fdd2z2 = fdd2z2+factor2*xijfa*(idd2z2(i,j)+eij/t*idd4z2(i,j))
5968  fdd2z3 = fdd2z3+factor2*xijfa*(idd2z3(i,j)+eij/t*idd4z3(i,j))
5969  fdd2z4 = fdd2z4+factor2*xijfa*(idd2z4(i,j)+eij/t*idd4z4(i,j))
5970  DO k = 1, ncomp
5971  ! IF (parame(k,6).NE.0.0) THEN
5972  xijkfa= x(i)*parame(i,3)/t*parame(i,2)**3 *x(j)*parame(j,3)/t*parame(j,2)**3 &
5973  *x(k)*parame(k,3)/t*parame(k,2)**3 /((parame(i,2)+parame(j,2))/2.0) &
5974  /((parame(i,2)+parame(k,2))/2.0) /((parame(j,2)+parame(k,2))/2.0) &
5975  *my2dd(i)*my2dd(j)*my2dd(k)
5976  fdd3 = fdd3 + factor3 * xijkfa*idd3(i,j,k)
5977  fdd3z = fdd3z + factor3 * xijkfa*idd3z(i,j,k)
5978  fdd3z2 = fdd3z2 + factor3 * xijkfa*idd3z2(i,j,k)
5979  fdd3z3 = fdd3z3 + factor3 * xijkfa*idd3z3(i,j,k)
5980  fdd3z4 = fdd3z4 + factor3 * xijkfa*idd3z4(i,j,k)
5981  ! ENDIF
5982  END DO
5983  ! ENDIF
5984  END DO
5985  END DO
5986  IF (fdd2 < -1.e-50 .AND. fdd3 /= 0.0 .AND. fdd2z /= 0.0 .AND. fdd3z /= 0.0) THEN
5987 
5988  fdddr= fdd2* (fdd2*fdd2z - 2.0*fdd3*fdd2z+fdd2*fdd3z) / (fdd2-fdd3)**2
5989  fddd2=(2.0*fdd2*fdd2z*fdd2z +fdd2*fdd2*fdd2z2 &
5990  -2.0*fdd2z**2 *fdd3-2.0*fdd2*fdd2z2*fdd3+fdd2*fdd2*fdd3z2) &
5991  /(fdd2-fdd3)**2 + fdddr * 2.0*(fdd3z-fdd2z)/(fdd2-fdd3)
5992  fddd3=(2.0*fdd2z**3 +6.0*fdd2*fdd2z*fdd2z2+fdd2*fdd2*fdd2z3 &
5993  -6.0*fdd2z*fdd2z2*fdd3-2.0*fdd2z**2 *fdd3z &
5994  -2.0*fdd2*fdd2z3*fdd3 -2.0*fdd2*fdd2z2*fdd3z &
5995  +2.0*fdd2*fdd2z*fdd3z2+fdd2*fdd2*fdd3z3) /(fdd2-fdd3)**2 &
5996  + 2.0/(fdd2-fdd3)* ( 2.0*fddd2*(fdd3z-fdd2z) &
5997  + fdddr*(fdd3z2-fdd2z2) &
5998  - fdddr/(fdd2-fdd3)*(fdd3z-fdd2z)**2 )
5999  fddd4=( 12.0*fdd2z**2 *fdd2z2+6.0*fdd2*fdd2z2**2 &
6000  +8.0*fdd2*fdd2z*fdd2z3+fdd2*fdd2*fdd2z4-6.0*fdd2z2**2 *fdd3 &
6001  -12.0*fdd2z*fdd2z2*fdd3z -8.0*fdd2z*fdd2z3*fdd3 &
6002  -2.0*fdd2*fdd2z4*fdd3-4.0*fdd2*fdd2z3*fdd3z &
6003  +4.0*fdd2*fdd2z*fdd3z3+fdd2**2 *fdd3z4 ) /(fdd2-fdd3)**2 &
6004  + 6.0/(fdd2-fdd3)* ( fddd3*(fdd3z-fdd2z) &
6005  -fddd2/(fdd2-fdd3)*(fdd3z-fdd2z)**2 &
6006  - fdddr/(fdd2-fdd3)*(fdd3z-fdd2z)*(fdd3z2-fdd2z2) &
6007  + fddd2*(fdd3z2-fdd2z2) +1.0/3.0*fdddr*(fdd3z3-fdd2z3) )
6008  zdd = fdddr*eta
6009  zddz = fddd2*eta + fdddr
6010  zddz2 = fddd3*eta + 2.0* fddd2
6011  zddz3 = fddd4*eta + 3.0* fddd3
6012 
6013  END IF
6014 
6015 
6016 END SUBROUTINE p_dd_gross_vrabec
6017 
6018 
6019 
6020 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6021 !
6022 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6023 !
6024  SUBROUTINE p_qq_gross( zqq, zqqz, zqqz2, zqqz3 )
6025 !
6026  USE parameters, ONLY: pi, kbol
6027  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
6028  USE eos_constants, ONLY: qqp2, qqp3, qqp4
6029  IMPLICIT NONE
6030 !
6031 ! ----------------------------------------------------------------------
6032  REAL, INTENT(IN OUT) :: zqq, zqqz, zqqz2, zqqz3
6033 ! ----------------------------------------------------------------------
6034  INTEGER :: i, j, k, m
6035  REAL :: factor2, factor3, z3
6036  REAL :: xijfa, xijkfa, eij
6037  REAL :: fqqdr, fqqd2, fqqd3, fqqd4
6038  REAL :: fqq2, fqq2z, fqq2z2, fqq2z3, fqq2z4
6039  REAL :: fqq3, fqq3z, fqq3z2, fqq3z3, fqq3z4
6040  REAL, DIMENSION(nc) :: qq2
6041  REAL, DIMENSION(nc,nc) :: iqq2, iqq2z, iqq2z2, iqq2z3, iqq2z4
6042  REAL, DIMENSION(nc,nc) :: iqq4, iqq4z, iqq4z2, iqq4z3, iqq4z4
6043  REAL, DIMENSION(nc,nc,nc) :: iqq3, iqq3z, iqq3z2, iqq3z3, iqq3z4
6044 ! ----------------------------------------------------------------------
6045 
6046  zqq = 0.0
6047  zqqz = 0.0
6048  zqqz2 = 0.0
6049  zqqz3 = 0.0
6050  z3 = eta
6051  DO i=1,ncomp
6052  qq2(i) = (parame(i,7))**2 *1.e-69 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**5 *1.e-50)
6053  END DO
6054 
6055  DO i = 1, ncomp
6056  DO j = 1, ncomp
6057  iqq2(i,j) = 0.0
6058  iqq4(i,j) = 0.0
6059  iqq2z(i,j) = 0.0
6060  iqq4z(i,j) = 0.0
6061  iqq2z2(i,j) = 0.0
6062  iqq4z2(i,j) = 0.0
6063  iqq2z3(i,j) = 0.0
6064  iqq4z3(i,j) = 0.0
6065  iqq2z4(i,j) = 0.0
6066  iqq4z4(i,j) = 0.0
6067  IF (parame(i,7) /= 0.0 .AND. parame(j,7) /= 0.0) THEN
6068  DO m = 0, 4
6069  iqq2(i,j) =iqq2(i,j) + qqp2(i,j,m)*z3**(m+1)
6070  iqq4(i,j) =iqq4(i,j) + qqp4(i,j,m)*z3**(m+1)
6071  iqq2z(i,j) =iqq2z(i,j) +qqp2(i,j,m)*REAL(m+1)*z3**m
6072  iqq4z(i,j) =iqq4z(i,j) +qqp4(i,j,m)*REAL(m+1)*z3**m
6073  iqq2z2(i,j)=iqq2z2(i,j)+qqp2(i,j,m)*REAL((m+1)*m)*z3**(m-1)
6074  iqq4z2(i,j)=iqq4z2(i,j)+qqp4(i,j,m)*REAL((m+1)*m)*z3**(m-1)
6075  iqq2z3(i,j)=iqq2z3(i,j)+qqp2(i,j,m)*REAL((m+1)*m*(m-1)) *z3**(m-2)
6076  iqq4z3(i,j)=iqq4z3(i,j)+qqp4(i,j,m)*REAL((m+1)*m*(m-1)) *z3**(m-2)
6077  iqq2z4(i,j)=iqq2z4(i,j)+qqp2(i,j,m)*REAL((m+1)*m*(m-1)*(m-2)) *z3**(m-3)
6078  iqq4z4(i,j)=iqq4z4(i,j)+qqp4(i,j,m)*REAL((m+1)*m*(m-1)*(m-2)) *z3**(m-3)
6079  END DO
6080  DO k=1,ncomp
6081  iqq3(i,j,k) = 0.0
6082  iqq3z(i,j,k) = 0.0
6083  iqq3z2(i,j,k) = 0.0
6084  iqq3z3(i,j,k) = 0.0
6085  iqq3z4(i,j,k) = 0.0
6086  IF (parame(k,7) /= 0.0) THEN
6087  DO m=0,4
6088  iqq3(i,j,k) =iqq3(i,j,k) + qqp3(i,j,k,m)*z3**(m+2)
6089  iqq3z(i,j,k)=iqq3z(i,j,k)+qqp3(i,j,k,m)*REAL(m+2)*z3**(m+1)
6090  iqq3z2(i,j,k)=iqq3z2(i,j,k)+qqp3(i,j,k,m)*REAL((m+2)*(m+1)) *z3**m
6091  iqq3z3(i,j,k)=iqq3z3(i,j,k)+qqp3(i,j,k,m)*REAL((m+2)*(m+1)*m) *z3**(m-1)
6092  iqq3z4(i,j,k)=iqq3z4(i,j,k)+qqp3(i,j,k,m) *REAL((m+2)*(m+1)*m*(m-1)) *z3**(m-2)
6093  END DO
6094  END IF
6095  END DO
6096 
6097  END IF
6098  END DO
6099  END DO
6100 
6101  factor2= -9.0/16.0*pi *rho/z3
6102  factor3= 9.0/16.0*pi**2 * (rho/z3)**2
6103 
6104  fqq2 = 0.0
6105  fqq2z = 0.0
6106  fqq2z2 = 0.0
6107  fqq2z3 = 0.0
6108  fqq2z4 = 0.0
6109  fqq3 = 0.0
6110  fqq3z = 0.0
6111  fqq3z2 = 0.0
6112  fqq3z3 = 0.0
6113  fqq3z4 = 0.0
6114  DO i = 1, ncomp
6115  DO j = 1, ncomp
6116  IF (parame(i,7) /= 0.0 .AND. parame(j,7) /= 0.0) THEN
6117  xijfa =x(i)*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /t &
6118  *x(j)*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /t/sig_ij(i,j)**7.0
6119  eij = (parame(i,3)*parame(j,3))**0.5
6120  fqq2= fqq2 +factor2*xijfa*(iqq2(i,j) +eij/t*iqq4(i,j) )
6121  fqq2z =fqq2z +factor2*xijfa*(iqq2z(i,j) +eij/t*iqq4z(i,j) )
6122  fqq2z2=fqq2z2+factor2*xijfa*(iqq2z2(i,j)+eij/t*iqq4z2(i,j))
6123  fqq2z3=fqq2z3+factor2*xijfa*(iqq2z3(i,j)+eij/t*iqq4z3(i,j))
6124  fqq2z4=fqq2z4+factor2*xijfa*(iqq2z4(i,j)+eij/t*iqq4z4(i,j))
6125  DO k = 1, ncomp
6126  IF (parame(k,7) /= 0.0) THEN
6127  xijkfa=x(i)*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /t/sig_ij(i,j)**3 &
6128  *x(j)*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /t/sig_ij(i,k)**3 &
6129  *x(k)*uij(k,k)*qq2(k)*sig_ij(k,k)**5 /t/sig_ij(j,k)**3
6130  fqq3 = fqq3 + factor3 * xijkfa*iqq3(i,j,k)
6131  fqq3z = fqq3z + factor3 * xijkfa*iqq3z(i,j,k)
6132  fqq3z2 = fqq3z2 + factor3 * xijkfa*iqq3z2(i,j,k)
6133  fqq3z3 = fqq3z3 + factor3 * xijkfa*iqq3z3(i,j,k)
6134  fqq3z4 = fqq3z4 + factor3 * xijkfa*iqq3z4(i,j,k)
6135  END IF
6136  END DO
6137  END IF
6138  END DO
6139  END DO
6140  IF (fqq2 < -1.e-50 .AND. fqq3 /= 0.0 .AND. fqq2z /= 0.0 .AND. fqq3z /= 0.0) THEN
6141  fqqdr = fqq2* (fqq2*fqq2z - 2.0*fqq3*fqq2z+fqq2*fqq3z) /(fqq2-fqq3)**2
6142  fqqd2= (2.0*fqq2*fqq2z*fqq2z +fqq2*fqq2*fqq2z2 &
6143  -2.0*fqq2z**2 *fqq3-2.0*fqq2*fqq2z2*fqq3+fqq2*fqq2*fqq3z2) &
6144  /(fqq2-fqq3)**2 + fqqdr * 2.0*(fqq3z-fqq2z)/(fqq2-fqq3)
6145  fqqd3=(2.0*fqq2z**3 +6.0*fqq2*fqq2z*fqq2z2+fqq2*fqq2*fqq2z3 &
6146  -6.0*fqq2z*fqq2z2*fqq3-2.0*fqq2z**2 *fqq3z &
6147  -2.0*fqq2*fqq2z3*fqq3 -2.0*fqq2*fqq2z2*fqq3z &
6148  +2.0*fqq2*fqq2z*fqq3z2+fqq2*fqq2*fqq3z3) /(fqq2-fqq3)**2 &
6149  + 2.0/(fqq2-fqq3)* ( 2.0*fqqd2*(fqq3z-fqq2z) &
6150  + fqqdr*(fqq3z2-fqq2z2) - fqqdr/(fqq2-fqq3)*(fqq3z-fqq2z)**2 )
6151  fqqd4=( 12.0*fqq2z**2 *fqq2z2+6.0*fqq2*fqq2z2**2 &
6152  +8.0*fqq2*fqq2z*fqq2z3+fqq2*fqq2*fqq2z4-6.0*fqq2z2**2 *fqq3 &
6153  -12.0*fqq2z*fqq2z2*fqq3z -8.0*fqq2z*fqq2z3*fqq3 &
6154  -2.0*fqq2*fqq2z4*fqq3-4.0*fqq2*fqq2z3*fqq3z &
6155  +4.0*fqq2*fqq2z*fqq3z3+fqq2**2 *fqq3z4 ) /(fqq2-fqq3)**2 &
6156  + 6.0/(fqq2-fqq3)* ( fqqd3*(fqq3z-fqq2z) &
6157  -fqqd2/(fqq2-fqq3)*(fqq3z-fqq2z)**2 &
6158  - fqqdr/(fqq2-fqq3)*(fqq3z-fqq2z)*(fqq3z2-fqq2z2) &
6159  + fqqd2*(fqq3z2-fqq2z2) +1.0/3.0*fqqdr*(fqq3z3-fqq2z3) )
6160  zqq = fqqdr*eta
6161  zqqz = fqqd2*eta + fqqdr
6162  zqqz2 = fqqd3*eta + 2.0* fqqd2
6163  zqqz3 = fqqd4*eta + 3.0* fqqd3
6164  END IF
6165 
6166 
6167 END SUBROUTINE p_qq_gross
6168 
6169 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6170 !
6171 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6172 !
6173  SUBROUTINE p_dq_vrabec_gross( zdq, zdqz, zdqz2, zdqz3 )
6174 !
6175  USE parameters, ONLY: pi, kbol
6176  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
6177  USE eos_constants, ONLY: dqp2, dqp3, dqp4
6178  IMPLICIT NONE
6179 !
6180 ! ----------------------------------------------------------------------
6181  REAL, INTENT(IN OUT) :: zdq, zdqz, zdqz2, zdqz3
6182 ! ----------------------------------------------------------------------
6183  INTEGER :: i, j, k, m
6184  REAL :: factor2, factor3, z3
6185  REAL :: xijfa, xijkfa, eij
6186  REAL :: fdqdr, fdqd2, fdqd3, fdqd4
6187  REAL :: fdq2, fdq2z, fdq2z2, fdq2z3, fdq2z4
6188  REAL :: fdq3, fdq3z, fdq3z2, fdq3z3, fdq3z4
6189  REAL, DIMENSION(nc) :: my2dd, myfac, qq2, q_fac
6190  REAL, DIMENSION(nc,nc) :: idq2, idq2z, idq2z2, idq2z3, idq2z4
6191  REAL, DIMENSION(nc,nc) :: idq4, idq4z, idq4z2, idq4z3, idq4z4
6192  REAL, DIMENSION(nc,nc,nc) :: idq3, idq3z, idq3z2, idq3z3, idq3z4
6193 ! ----------------------------------------------------------------------
6194 
6195  zdq = 0.0
6196  zdqz = 0.0
6197  zdqz2 = 0.0
6198  zdqz3 = 0.0
6199  z3 = eta
6200  DO i = 1, ncomp
6201  my2dd(i) = (parame(i,6))**2 *1.e-49 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**3 *1.e-30)
6202  myfac(i) = parame(i,3)/t*parame(i,2)**4 *my2dd(i)
6203  qq2(i) = (parame(i,7))**2 *1.e-69 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**5 *1.e-50)
6204  q_fac(i) = parame(i,3)/t*parame(i,2)**4 *qq2(i)
6205  END DO
6206 
6207 
6208  DO i = 1, ncomp
6209  DO j = 1, ncomp
6210  idq2(i,j) = 0.0
6211  idq4(i,j) = 0.0
6212  idq2z(i,j) = 0.0
6213  idq4z(i,j) = 0.0
6214  idq2z2(i,j) = 0.0
6215  idq4z2(i,j) = 0.0
6216  idq2z3(i,j) = 0.0
6217  idq4z3(i,j) = 0.0
6218  idq2z4(i,j) = 0.0
6219  idq4z4(i,j) = 0.0
6220  IF (myfac(i) /= 0.0 .AND. q_fac(j) /= 0.0) THEN
6221  DO m = 0, 4
6222  idq2(i,j) =idq2(i,j) + dqp2(i,j,m)*z3**(m+1)
6223  idq4(i,j) =idq4(i,j) + dqp4(i,j,m)*z3**(m+1)
6224  idq2z(i,j) =idq2z(i,j) +dqp2(i,j,m)*REAL(m+1)*z3**m
6225  idq4z(i,j) =idq4z(i,j) +dqp4(i,j,m)*REAL(m+1)*z3**m
6226  idq2z2(i,j)=idq2z2(i,j)+dqp2(i,j,m)*REAL((m+1)*m)*z3**(m-1)
6227  idq4z2(i,j)=idq4z2(i,j)+dqp4(i,j,m)*REAL((m+1)*m)*z3**(m-1)
6228  idq2z3(i,j)=idq2z3(i,j)+dqp2(i,j,m)*REAL((m+1)*m*(m-1)) *z3**(m-2)
6229  idq4z3(i,j)=idq4z3(i,j)+dqp4(i,j,m)*REAL((m+1)*m*(m-1)) *z3**(m-2)
6230  idq2z4(i,j)=idq2z4(i,j)+dqp2(i,j,m)*REAL((m+1)*m*(m-1)*(m-2)) *z3**(m-3)
6231  idq4z4(i,j)=idq4z4(i,j)+dqp4(i,j,m)*REAL((m+1)*m*(m-1)*(m-2)) *z3**(m-3)
6232  END DO
6233  DO k = 1, ncomp
6234  idq3(i,j,k) = 0.0
6235  idq3z(i,j,k) = 0.0
6236  idq3z2(i,j,k) = 0.0
6237  idq3z3(i,j,k) = 0.0
6238  idq3z4(i,j,k) = 0.0
6239  IF (myfac(k) /= 0.0.OR.q_fac(k) /= 0.0) THEN
6240  DO m = 0, 4
6241  idq3(i,j,k) =idq3(i,j,k) + dqp3(i,j,k,m)*z3**(m+2)
6242  idq3z(i,j,k)=idq3z(i,j,k)+dqp3(i,j,k,m)*REAL(m+2)*z3**(m+1)
6243  idq3z2(i,j,k)=idq3z2(i,j,k)+dqp3(i,j,k,m)*REAL((m+2)*(m+1)) *z3**m
6244  idq3z3(i,j,k)=idq3z3(i,j,k)+dqp3(i,j,k,m)*REAL((m+2)*(m+1)*m) *z3**(m-1)
6245  idq3z4(i,j,k)=idq3z4(i,j,k)+dqp3(i,j,k,m) &
6246  *REAL((m+2)*(m+1)*m*(m-1)) *z3**(m-2)
6247  END DO
6248  END IF
6249  END DO
6250 
6251  END IF
6252  END DO
6253  END DO
6254 
6255  factor2= -9.0/4.0*pi *rho/z3
6256  factor3= pi**2 * (rho/z3)**2
6257 
6258  fdq2 = 0.0
6259  fdq2z = 0.0
6260  fdq2z2 = 0.0
6261  fdq2z3 = 0.0
6262  fdq2z4 = 0.0
6263  fdq3 = 0.0
6264  fdq3z = 0.0
6265  fdq3z2 = 0.0
6266  fdq3z3 = 0.0
6267  fdq3z4 = 0.0
6268  DO i = 1, ncomp
6269  DO j = 1, ncomp
6270  IF (myfac(i) /= 0.0 .AND. q_fac(j) /= 0.0) THEN
6271  xijfa =x(i)*myfac(i) * x(j)*q_fac(j) /sig_ij(i,j)**5
6272  eij = (parame(i,3)*parame(j,3))**0.5
6273  fdq2= fdq2 +factor2*xijfa*(idq2(i,j) +eij/t*idq4(i,j) )
6274  fdq2z =fdq2z +factor2*xijfa*(idq2z(i,j) +eij/t*idq4z(i,j) )
6275  fdq2z2=fdq2z2+factor2*xijfa*(idq2z2(i,j)+eij/t*idq4z2(i,j))
6276  fdq2z3=fdq2z3+factor2*xijfa*(idq2z3(i,j)+eij/t*idq4z3(i,j))
6277  fdq2z4=fdq2z4+factor2*xijfa*(idq2z4(i,j)+eij/t*idq4z4(i,j))
6278  DO k = 1, ncomp
6279  IF (myfac(k) /= 0.0.OR.q_fac(k) /= 0.0) THEN
6280  xijkfa=x(i)*x(j)*x(k)/(sig_ij(i,j)*sig_ij(i,k)*sig_ij(j,k))**2 &
6281  *( myfac(i)*q_fac(j)*myfac(k) + myfac(i)*q_fac(j)*q_fac(k)*1.193735 )
6282  fdq3 =fdq3 + factor3 * xijkfa*idq3(i,j,k)
6283  fdq3z =fdq3z + factor3 * xijkfa*idq3z(i,j,k)
6284  fdq3z2=fdq3z2 + factor3 * xijkfa*idq3z2(i,j,k)
6285  fdq3z3=fdq3z3 + factor3 * xijkfa*idq3z3(i,j,k)
6286  fdq3z4=fdq3z4 + factor3 * xijkfa*idq3z4(i,j,k)
6287  END IF
6288  END DO
6289  END IF
6290  END DO
6291  END DO
6292  IF (fdq2 < -1.e-50 .AND. fdq3 /= 0.0 .AND. fdq2z /= 0.0 .AND. fdq3z /= 0.0) THEN
6293  fdqdr = fdq2* (fdq2*fdq2z - 2.0*fdq3*fdq2z+fdq2*fdq3z) /(fdq2-fdq3)**2
6294  fdqd2= (2.0*fdq2*fdq2z*fdq2z +fdq2*fdq2*fdq2z2 &
6295  -2.0*fdq2z**2 *fdq3-2.0*fdq2*fdq2z2*fdq3+fdq2*fdq2*fdq3z2) &
6296  /(fdq2-fdq3)**2 + fdqdr * 2.0*(fdq3z-fdq2z)/(fdq2-fdq3)
6297  fdqd3=(2.0*fdq2z**3 +6.0*fdq2*fdq2z*fdq2z2+fdq2*fdq2*fdq2z3 &
6298  -6.0*fdq2z*fdq2z2*fdq3-2.0*fdq2z**2 *fdq3z &
6299  -2.0*fdq2*fdq2z3*fdq3 -2.0*fdq2*fdq2z2*fdq3z &
6300  +2.0*fdq2*fdq2z*fdq3z2+fdq2*fdq2*fdq3z3) /(fdq2-fdq3)**2 &
6301  + 2.0/(fdq2-fdq3)* ( 2.0*fdqd2*(fdq3z-fdq2z) &
6302  + fdqdr*(fdq3z2-fdq2z2) - fdqdr/(fdq2-fdq3)*(fdq3z-fdq2z)**2 )
6303  fdqd4=( 12.0*fdq2z**2 *fdq2z2+6.0*fdq2*fdq2z2**2 &
6304  +8.0*fdq2*fdq2z*fdq2z3+fdq2*fdq2*fdq2z4-6.0*fdq2z2**2 *fdq3 &
6305  -12.0*fdq2z*fdq2z2*fdq3z -8.0*fdq2z*fdq2z3*fdq3 &
6306  -2.0*fdq2*fdq2z4*fdq3-4.0*fdq2*fdq2z3*fdq3z &
6307  +4.0*fdq2*fdq2z*fdq3z3+fdq2**2 *fdq3z4 ) /(fdq2-fdq3)**2 &
6308  + 6.0/(fdq2-fdq3)* ( fdqd3*(fdq3z-fdq2z) &
6309  -fdqd2/(fdq2-fdq3)*(fdq3z-fdq2z)**2 &
6310  - fdqdr/(fdq2-fdq3)*(fdq3z-fdq2z)*(fdq3z2-fdq2z2) &
6311  + fdqd2*(fdq3z2-fdq2z2) +1.0/3.0*fdqdr*(fdq3z3-fdq2z3) )
6312  zdq = fdqdr*eta
6313  zdqz = fdqd2*eta + fdqdr
6314  zdqz2 = fdqd3*eta + 2.0* fdqd2
6315  zdqz3 = fdqd4*eta + 3.0* fdqd3
6316  END IF
6317 
6318 
6319 END SUBROUTINE p_dq_vrabec_gross
6320 
6321 
6322 
6323 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6324 !
6325 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6326 !
6327  SUBROUTINE f_pert_theory ( fdsp )
6328 !
6329  USE eos_variables, ONLY: nc, pi, ncomp, t, p, rho, eta, &
6330  x, z0t, mseg, parame, order1, order2
6331  USE eos_numerical_derivatives, ONLY: disp_term
6332  USE dft_module
6333  IMPLICIT NONE
6334 !
6335 !---------------------------------------------------------------------
6336  REAL, INTENT(IN OUT) :: fdsp
6337 !---------------------------------------------------------------------
6338  REAL :: i1, i2
6339  REAL :: z3, zms, c1_con, m_mean
6340 !---------------------------------------------------------------------
6341 
6342  ! caution: positive sign of correlation integral is used here !
6343  ! (the Helmholtz energy terms are written with a negative sign, while I1 and I2 are positive)
6344 
6345  IF (disp_term == 'PT1') THEN
6346 
6347  CALL f_dft ( i1, i2)
6348  c1_con = 0.0
6349  i2 = 0.0
6350  fdsp = + ( - 2.0*pi*rho*i1*order1 )
6351 
6352  ELSEIF (disp_term == 'PT2') THEN
6353 
6354  CALL f_dft ( i1, i2)
6355  z3 = eta
6356  zms = 1.0 - z3
6357  m_mean = z0t / ( pi / 6.0 )
6358  c1_con = 1.0/ ( 1.0 + m_mean*(8.0*z3-2.0*z3**2 )/zms**4 &
6359  + (1.0 - m_mean)*( 20.0*z3 -27.0*z3**2 +12.0*z3**3 -2.0*z3**4 ) &
6360  /(zms*(2.0-z3))**2 )
6361  fdsp = + ( - 2.0*pi*rho*i1*order1 - pi*rho*c1_con*m_mean*i2*order2 )
6362 
6363  ELSEIF (disp_term == 'PT_MIX') THEN
6364 
6365  CALL f_pert_theory_mix ( fdsp )
6366 
6367  ELSEIF (disp_term == 'PT_MF') THEN
6368 
6369  ! mean field theory
6370  i1 = - ( - 8.0/9.0 - 4.0/9.0*(rc**(-9) -3.0*rc**(-3) ) - tau_cut/3.0*(rc**3 -1.0) )
6371  fdsp = + ( - 2.0*pi*rho*i1*order1 )
6372  write (*,*) 'caution: not thoroughly checked and tested'
6373 
6374  ELSE
6375  write (*,*) 'define the type of perturbation theory'
6376  stop
6377  END IF
6378 
6379  ! I1 = I1 + 4.0/9.0*(2.5**-9 -3.0*2.5**-3 )
6380  ! fdsp = + ( - 2.0*PI*rho*I1*order1 - PI*rho*c1_con*m_mean*I2*order2 )
6381 
6382  END SUBROUTINE f_pert_theory
6383 
6384 
6385 
6386 
6387 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6388 !
6389 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6390 !
6391  SUBROUTINE f_pert_theory_mix ( fdsp )
6392 !
6393  USE eos_variables, ONLY: nc, pi, ncomp, t, rho, eta, x, parame, mseg, dhs, sig_ij, uij
6394  USE dft_module
6395  IMPLICIT NONE
6396 !
6397 ! ----------------------------------------------------------------------
6398  REAL, INTENT(IN OUT) :: fdsp
6399 !
6400 ! ----------------------------------------------------------------------
6401  INTEGER :: k, ih
6402  INTEGER :: l, m
6403  REAL :: z3
6404  REAL :: ua, ua_c, rm
6405  REAL, DIMENSION(nc,nc) :: i1
6406  REAL :: int10, int11
6407  REAL :: d_ij, dzr_local
6408  REAL :: rad, xg, rdf
6409  REAL :: dg_dz3, dg_dr
6410  ! REAL :: intgrid(0:5000),intgri2(0:5000), utri(5000),I1_spline
6411 ! ----------------------------------------------------------------------
6412 
6413 ! -----constants--------------------------------------------------------
6414  ua_c = 4.0 * ( rc**(-12) - rc**(-6) )
6415  rm = 2.0**(1.0/6.0)
6416 
6417  i1(:,:) = 0.0
6418 
6419  DO l = 1, ncomp
6420  DO m = 1, ncomp
6421 
6422  rad = rc
6423 
6424  int10 = rc * rc * ua_c
6425  ! intgrid(0)= int10
6426 
6427  k = 0
6428  ih = 85
6429 
6430  DO WHILE ( rad /= 1.0 )
6431 
6432  dzr_local = dzr
6433  IF ( rad - dzr_local <= 1.0 ) dzr_local = rad - 1.0
6434 
6435  rad = rad - dzr_local
6436 
6437  k = k + 1
6438 
6439  d_ij = 0.5*(dhs(l)+dhs(m)) / sig_ij(l,m) ! dimensionless effective hs-diameter d(T)/sig
6440  xg = rad / d_ij
6441  z3 = eta
6442  rdf = 1.0
6443  dg_dz3 = 0.0
6444  IF ( rad <= rg ) THEN
6445  IF ( l == 1 .AND. m == 1 ) CALL bi_cub_spline (z3,xg,ya_11,x1a_11,x2a_11,y1a_11,y2a_11,y12a_11, &
6446  c_bicub_11,rdf,dg_dz3,dg_dr,den_step,ih,k)
6447  IF ( l /= m ) CALL bi_cub_spline (z3,xg,ya_12,x1a_12,x2a_12,y1a_12,y2a_12,y12a_12, &
6448  c_bicub_12,rdf,dg_dz3,dg_dr,den_step,ih,k)
6449  IF ( l == 2 .AND. m == 2 ) CALL bi_cub_spline (z3,xg,ya_22,x1a_22,x2a_22,y1a_22,y2a_22,y12a_22, &
6450  c_bicub_22,rdf,dg_dz3,dg_dr,den_step,ih,k)
6451  END IF
6452 
6453  ua = 4.0 * ( rad**(-12) - rad**(-6) )
6454 
6455  int11 = rdf * rad * rad * ua
6456  i1(l,m) = i1(l,m) + dzr_local * ( int11 + int10 ) / 2.0
6457 
6458  int10 = int11
6459  ! intgrid(k)= int11
6460 
6461  END DO
6462 
6463  ! stepno = k
6464  ! CALL SPLINE_PARA (dzr,intgrid,utri,stepno)
6465  ! CALL SPLINE_INT (I1_spline,dzr,intgrid,utri,stepno)
6466 
6467 
6468  ! caution: 1st order integral is in F_EOS.f defined with negative sign
6469  ! ---------------------------------------------------------------
6470  ! cut-off corrections
6471  ! ---------------------------------------------------------------
6472  ! I1(l,m) = I1(l,m) + ( 4.0/9.0 * rc**-9 - 4.0/3.0 * rc**-3 )
6473  ! I2(l,m) = I2(l,m) + 16.0/21.0 * rc**-21 - 32.0/15.0 * rc**-15 + 16.0/9.0 * rc**-9
6474 
6475  END DO
6476  END DO
6477 
6478 
6479  fdsp = 0.0
6480  DO l = 1, ncomp
6481  DO m = 1, ncomp
6482  fdsp = fdsp + 2.0*pi*rho*x(l)*x(m)* mseg(l)*mseg(m)*sig_ij(l,m)**3 * uij(l,m)/t *i1(l,m)
6483  ! ( 2.0*PI*rho*I1*order1 - PI*rho*c1_con*m_mean*I2*order2 )
6484  END DO
6485  END DO
6486 
6487 
6488 !!$ IF (disp_term == 'PT1') THEN
6489 !!$ c1_con = 0.0
6490 !!$ I2 = 0.0
6491 !!$ ELSEIF (disp_term == 'PT2') THEN
6492 !!$ zms = 1.0 - z3
6493 !!$ c1_con = 1.0/ ( 1.0 + m_mean*(8.0*z3-2.0*z3**2 )/zms**4 &
6494 !!$ + (1.0 - m_mean)*( 20.0*z3 -27.0*z3**2 +12.0*z3**3 -2.0*z3**4 ) &
6495 !!$ /(zms*(2.0-z3))**2 )
6496 !!$ ELSE
6497 !!$ write (*,*) 'define the type of perturbation theory'
6498 !!$ stop
6499 !!$ END IF
6500 
6501 
6502 END SUBROUTINE f_pert_theory_mix
6503 
6504 
6505 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6506 !
6507 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6508 !
6509  SUBROUTINE mu_pert_theory_mix ( mu_dsp )
6510 !
6511  USE eos_variables, ONLY: nc, pi, ncomp, t, rho, eta, x, parame, mseg, dhs, sig_ij, uij
6512  USE dft_module
6513  IMPLICIT NONE
6514 !
6515 ! ----------------------------------------------------------------------
6516  REAL, INTENT(IN OUT) :: mu_dsp(nc)
6517 !
6518 ! ----------------------------------------------------------------------
6519  INTEGER :: k, ih
6520  INTEGER :: l, m
6521  REAL :: z3
6522  REAL :: ua, ua_c, rm
6523  REAL, DIMENSION(nc,nc) :: i1, i2
6524  REAL :: int1_0, int1_1, int2_0, int2_1
6525  REAL :: d_ij, dzr_local
6526  REAL :: rad, xg, rdf
6527  REAL :: dg_dz3, dg_dr
6528  REAL :: term1(nc), term2
6529  ! REAL :: intgrid(0:5000),intgri2(0:5000), utri(5000),I1_spline
6530 ! ----------------------------------------------------------------------
6531 
6532 ! -----constants--------------------------------------------------------
6533  ua_c = 4.0 * ( rc**(-12) - rc**(-6) )
6534  rm = 2.0**(1.0/6.0)
6535 
6536  i1(:,:) = 0.0
6537  i2(:,:) = 0.0
6538 
6539  DO l = 1, ncomp
6540 
6541  term1(l) = 0.0
6542 
6543  DO m = 1, ncomp
6544 
6545  rad = rc
6546 
6547  int1_0 = rc * rc * ua_c
6548  int2_0 = 0.0
6549 
6550  k = 0
6551  ih = 85
6552 
6553  DO WHILE ( rad /= 1.0 )
6554 
6555  dzr_local = dzr
6556  IF ( rad - dzr_local <= 1.0 ) dzr_local = rad - 1.0
6557 
6558  rad = rad - dzr_local
6559  k = k + 1
6560 
6561  d_ij = 0.5*(dhs(l)+dhs(m)) / sig_ij(l,m) ! dimensionless effective hs-diameter d(T)/sig
6562  xg = rad / d_ij
6563  z3 = eta
6564  rdf = 1.0
6565  dg_dz3 = 0.0
6566  IF ( rad <= rg ) THEN
6567  IF ( l == 1 .AND. m == 1 ) CALL bi_cub_spline (z3,xg,ya_11,x1a_11,x2a_11,y1a_11,y2a_11,y12a_11, &
6568  c_bicub_11,rdf,dg_dz3,dg_dr,den_step,ih,k)
6569  IF ( l /= m ) CALL bi_cub_spline (z3,xg,ya_12,x1a_12,x2a_12,y1a_12,y2a_12,y12a_12, &
6570  c_bicub_12,rdf,dg_dz3,dg_dr,den_step,ih,k)
6571  IF ( l == 2 .AND. m == 2 ) CALL bi_cub_spline (z3,xg,ya_22,x1a_22,x2a_22,y1a_22,y2a_22,y12a_22, &
6572  c_bicub_22,rdf,dg_dz3,dg_dr,den_step,ih,k)
6573  END IF
6574 
6575  ua = 4.0 * ( rad**(-12) - rad**(-6) )
6576 
6577  int1_1 = rdf * rad * rad * ua
6578  int2_1 = dg_dz3 * rad * rad * ua
6579  i1(l,m) = i1(l,m) + dzr_local * ( int1_1 + int1_0 ) / 2.0
6580  i2(l,m) = i2(l,m) + dzr_local * ( int2_1 + int2_0 ) / 2.0
6581 
6582  int1_0 = int1_1
6583  int2_0 = int2_1
6584 
6585  term1(l) = term1(l) +4.0*pi*rho*x(m)* mseg(l)*mseg(m) *sig_ij(l,m)**3 *uij(l,m)/t* dzr_local*(int1_1+int1_0)/2.0
6586 
6587  END DO
6588 
6589  END DO
6590  END DO
6591 
6592 
6593  ! DO l = 1, ncomp
6594  ! term1(l) = 0.0
6595  ! DO m = 1, ncomp
6596  ! term1(l) = term1(l) + 4.0*PI*rho*x(m)* mseg(l)*mseg(m) * sig_ij(l,m)**3 * uij(l,m)/t *I1(l,m)
6597  ! END DO
6598  ! END DO
6599 
6600  term2 = 0.0
6601  DO l = 1, ncomp
6602  DO m = 1, ncomp
6603  term2 = term2 + 2.0*pi*rho*x(l) * rho*x(m)* mseg(l)*mseg(m) * sig_ij(l,m)**3 * uij(l,m)/t *i2(l,m)
6604  END DO
6605  END DO
6606 
6607  DO l = 1, ncomp
6608  mu_dsp(l) = term1(l) + term2 * pi/ 6.0 * mseg(l)*dhs(l)**3
6609  END DO
6610 
6611 END SUBROUTINE mu_pert_theory_mix
6612 
6613 
6614 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6615 !
6616 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6617 !
6618  SUBROUTINE f_dd_gross_vrabec( fdd )
6619 !
6620  USE parameters, ONLY: pi, kbol
6621  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
6622  USE eos_constants, ONLY: ddp2, ddp3, ddp4
6623  IMPLICIT NONE
6624 !
6625 ! ----------------------------------------------------------------------
6626  REAL, INTENT(IN OUT) :: fdd
6627 ! ----------------------------------------------------------------------
6628  INTEGER :: i, j, k, m
6629  INTEGER :: ddit, ddmax
6630  REAL :: factor2, factor3
6631  REAL :: xijfa, xijkfa, xijf_j, xijkf_j, eij
6632  REAL :: fdd2, fdd3
6633  REAL, DIMENSION(nc) :: my2dd, my0, alph_tst, z1dd, z2dd, dderror
6634  REAL, DIMENSION(nc) :: fdd2m, fdd3m, fdd2m2, fdd3m2, fddm, fddm2
6635  REAL, DIMENSION(nc,nc) :: idd2, idd4
6636  REAL, DIMENSION(nc,nc,nc) :: idd3
6637 ! ----------------------------------------------------------------------
6638 
6639  fdd = 0.0
6640  ddit = 0
6641  ddmax = 0 ! value assigned, if polarizable compound is present
6642  fddm(:) = 0.0
6643  DO i = 1, ncomp
6644  IF ( uij(i,i) == 0.0 ) write (*,*) 'F_DD_GROSS_VRABEC: do not use dimensionless units'
6645  IF ( uij(i,i) == 0.0 ) stop
6646  my2dd(i) = (parame(i,6))**2 *1.e-49 /(uij(i,i)*kbol* mseg(i)*sig_ij(i,i)**3 *1.e-30)
6647  alph_tst(i) = parame(i,11) / (mseg(i)*sig_ij(i,i)**3 ) * t/parame(i,3)
6648  IF ( alph_tst(i) /= 0.0 ) ddmax = 25 ! set maximum number of polarizable RGT-iterations
6649  z1dd(i) = my2dd(i) + 3.0*alph_tst(i)
6650  z2dd(i) = 3.0*alph_tst(i)
6651  my0(i) = my2dd(i)
6652  END DO
6653 
6654  DO i = 1, ncomp
6655  DO j = 1, ncomp
6656  idd2(i,j) = 0.0
6657  idd4(i,j) = 0.0
6658  ! IF (parame(i,6).NE.0.0 .AND. parame(j,6).NE.0.0) THEN
6659  DO m = 0, 4
6660  idd2(i,j) = idd2(i,j) + ddp2(i,j,m)*eta**m
6661  idd4(i,j) = idd4(i,j) + ddp4(i,j,m)*eta**m
6662  END DO
6663  DO k = 1, ncomp
6664  idd3(i,j,k) = 0.0
6665  ! IF (parame(k,6).NE.0.0) THEN
6666  DO m = 0, 4
6667  idd3(i,j,k) = idd3(i,j,k) + ddp3(i,j,k,m)*eta**m
6668  END DO
6669  ! ENDIF
6670  END DO
6671  ! ENDIF
6672  END DO
6673  END DO
6674 
6675  factor2 = -pi *rho
6676  factor3 = -4.0/3.0*pi**2 * rho**2
6677 
6678 9 CONTINUE
6679 
6680  fdd2m(:) = 0.0
6681  fdd2m2(:) = 0.0
6682  fdd3m(:) = 0.0
6683  fdd3m2(:) = 0.0
6684  fdd2 = 0.0
6685  fdd3 = 0.0
6686  DO i = 1, ncomp
6687  DO j = 1, ncomp
6688  ! IF (parame(i,6).NE.0.0 .AND. parame(j,6).NE.0.0) THEN
6689  xijfa =x(i)*parame(i,3)/t*parame(i,2)**3 * x(j)*parame(j,3)/t*parame(j,2)**3 &
6690  /((parame(i,2)+parame(j,2))/2.0)**3 * (z1dd(i)*z1dd(j)-z2dd(i)*z2dd(j)) ! * (1.0-lij(i,j))
6691  eij = (parame(i,3)*parame(j,3))**0.5
6692  fdd2= fdd2 + factor2 * xijfa * ( idd2(i,j) + eij/t*idd4(i,j) )
6693  xijf_j = parame(i,3)/t*parame(i,2)**3 *x(j)*parame(j,3)/t*parame(j,2)**3 &
6694  /((parame(i,2)+parame(j,2))/2.0)**3 ! * (1.0-lij(i,j))
6695  fdd2m(i)=fdd2m(i)+4.0*sqrt(my2dd(i))*z1dd(j)*factor2* xijf_j *(idd2(i,j)+eij/t*idd4(i,j))
6696  fdd2m2(i)=fdd2m2(i) + 4.0*z1dd(j)*factor2* xijf_j *(idd2(i,j)+eij/t*idd4(i,j))
6697  IF (j == i) fdd2m2(i) =fdd2m2(i) +8.0*factor2* xijf_j*my2dd(i) *(idd2(i,j)+eij/t*idd4(i,j))
6698  DO k = 1, ncomp
6699  ! IF (parame(k,6).NE.0.0) THEN
6700  xijkfa = x(i)*parame(i,3)/t*parame(i,2)**3 *x(j)*parame(j,3)/t*parame(j,2)**3 &
6701  *x(k)*parame(k,3)/t*parame(k,2)**3 / ((parame(i,2)+parame(j,2))/2.0) &
6702  /((parame(i,2)+parame(k,2))/2.0) / ((parame(j,2)+parame(k,2))/2.0) &
6703  *(z1dd(i)*z1dd(j)*z1dd(k)-z2dd(i)*z2dd(j)*z2dd(k))
6704  ! *(1.0-lij(i,j))*(1.0-lij(i,k))*(1.0-lij(j,k))
6705  fdd3 = fdd3 + factor3 * xijkfa * idd3(i,j,k)
6706  xijkf_j = parame(i,3)/t*parame(i,2)**3 *x(j)*parame(j,3)/t*parame(j,2)**3 &
6707  *x(k)*parame(k,3)/t*parame(k,2)**3 /((parame(i,2)+parame(j,2))/2.0) &
6708  /((parame(i,2)+parame(k,2))/2.0) /((parame(j,2)+parame(k,2))/2.0)
6709  ! *(1.0-lij(i,j))*(1.0-lij(i,k))*(1.0-lij(j,k))
6710  fdd3m(i)=fdd3m(i)+6.0*factor3*sqrt(my2dd(i))*z1dd(j)*z1dd(k) *xijkf_j*idd3(i,j,k)
6711  fdd3m2(i)=fdd3m2(i)+6.0*factor3*z1dd(j)*z1dd(k) *xijkf_j*idd3(i,j,k)
6712  IF(j == i) fdd3m2(i) =fdd3m2(i)+24.0*factor3*my2dd(i)*z1dd(k) *xijkf_j*idd3(i,j,k)
6713  ! ENDIF
6714  END DO
6715  ! ENDIF
6716  END DO
6717  END DO
6718 
6719  IF (fdd2 < -1.e-50 .AND. fdd3 /= 0.0) THEN
6720  fdd = fdd2 / ( 1.0 - fdd3/fdd2 )
6721  IF ( ddmax /= 0 ) THEN
6722  DO i = 1, ncomp
6723  ddit = ddit + 1
6724  fddm(i) =fdd2*(fdd2*fdd2m(i) -2.0*fdd3*fdd2m(i)+fdd2*fdd3m(i)) /(fdd2-fdd3)**2
6725  fddm2(i) = fdd2m(i) * (fdd2*fdd2m(i)-2.0*fdd3*fdd2m(i) +fdd2*fdd3m(i)) / (fdd2-fdd3)**2 &
6726  + fdd2*(fdd2*fdd2m2(i) -2.0*fdd3*fdd2m2(i)+fdd2m(i)**2 &
6727  -fdd2m(i)*fdd3m(i) +fdd2*fdd3m2(i)) / (fdd2-fdd3)**2 &
6728  - 2.0*fdd2*(fdd2*fdd2m(i) -2.0*fdd3*fdd2m(i) +fdd2*fdd3m(i)) /(fdd2-fdd3)**3 &
6729  *(fdd2m(i)-fdd3m(i))
6730  dderror(i)= sqrt( my2dd(i) ) - sqrt( my0(i) ) + alph_tst(i)*fddm(i)
6731  my2dd(i) = ( sqrt( my2dd(i) ) - dderror(i) / (1.0+alph_tst(i)*fddm2(i)) )**2
6732  z1dd(i) = my2dd(i) + 3.0 * alph_tst(i)
6733  ENDDO
6734  DO i = 1, ncomp
6735  IF (abs(dderror(i)) > 1.e-11 .AND. ddit < ddmax) GOTO 9
6736  ENDDO
6737  fdd = fdd + sum( 0.5*x(1:ncomp)*alph_tst(1:ncomp)*fddm(1:ncomp)**2 )
6738  ENDIF
6739  END IF
6740 
6741 
6742 END SUBROUTINE f_dd_gross_vrabec
6743 
6744 
6745 
6746 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6747 !
6748 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6749 !
6750  SUBROUTINE f_qq_gross( fqq )
6751 !
6752  USE parameters, ONLY: pi, kbol
6753  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
6754  USE eos_constants, ONLY: qqp2, qqp3, qqp4
6755  IMPLICIT NONE
6756 !
6757 ! ----------------------------------------------------------------------
6758  REAL, INTENT(IN OUT) :: fqq
6759 ! ----------------------------------------------------------------------
6760  INTEGER :: i, j, k, m
6761  REAL :: factor2, factor3
6762  REAL :: xijfa, xijkfa, eij
6763  REAL :: fqq2, fqq3
6764  REAL, DIMENSION(nc) :: qq2
6765  REAL, DIMENSION(nc,nc) :: iqq2, iqq4
6766  REAL, DIMENSION(nc,nc,nc) :: iqq3
6767 ! ----------------------------------------------------------------------
6768 
6769 
6770  fqq = 0.0
6771  DO i = 1, ncomp
6772  qq2(i) = (parame(i,7))**2 *1.e-69 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**5 *1.e-50)
6773  END DO
6774 
6775  DO i = 1, ncomp
6776  DO j = 1, ncomp
6777  iqq2(i,j) = 0.0
6778  iqq4(i,j) = 0.0
6779  IF (parame(i,7) /= 0.0 .AND. parame(j,7) /= 0.0) THEN
6780  DO m = 0, 4
6781  iqq2(i,j) = iqq2(i,j) + qqp2(i,j,m)*eta**m
6782  iqq4(i,j) = iqq4(i,j) + qqp4(i,j,m)*eta**m
6783  END DO
6784  DO k = 1, ncomp
6785  iqq3(i,j,k) = 0.0
6786  IF (parame(k,7) /= 0.0) THEN
6787  DO m = 0, 4
6788  iqq3(i,j,k) = iqq3(i,j,k) + qqp3(i,j,k,m)*eta**m
6789  END DO
6790  END IF
6791  END DO
6792  END IF
6793  END DO
6794  END DO
6795 
6796  factor2 = -9.0/16.0*pi *rho
6797  factor3 = 9.0/16.0*pi**2 * rho**2
6798 
6799  fqq2 = 0.0
6800  fqq3 = 0.0
6801  DO i = 1, ncomp
6802  DO j = 1, ncomp
6803  IF (parame(i,7) /= 0.0 .AND. parame(j,7) /= 0.0) THEN
6804  xijfa=x(i)*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /t &
6805  *x(j)*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /t/sig_ij(i,j)**7.0
6806  eij = (parame(i,3)*parame(j,3))**0.5
6807  fqq2= fqq2 +factor2* xijfa * (iqq2(i,j)+eij/t*iqq4(i,j))
6808  DO k = 1, ncomp
6809  IF (parame(k,7) /= 0.0) THEN
6810  xijkfa=x(i)*uij(i,i)*qq2(i)*sig_ij(i,i)**5 /t/sig_ij(i,j)**3 &
6811  *x(j)*uij(j,j)*qq2(j)*sig_ij(j,j)**5 /t/sig_ij(i,k)**3 &
6812  *x(k)*uij(k,k)*qq2(k)*sig_ij(k,k)**5 /t/sig_ij(j,k)**3
6813  fqq3 = fqq3 + factor3 * xijkfa * iqq3(i,j,k)
6814  END IF
6815  END DO
6816  END IF
6817  END DO
6818  END DO
6819 
6820  IF ( fqq2 < -1.e-50 .AND. fqq3 /= 0.0 ) THEN
6821  fqq = fqq2 / ( 1.0 - fqq3/fqq2 )
6822  END IF
6823 
6824 
6825 
6826 END SUBROUTINE f_qq_gross
6827 
6828 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6829 !
6830 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6831 !
6832  SUBROUTINE f_dq_vrabec_gross( fdq )
6833 !
6834  USE parameters, ONLY: pi, kbol
6835  USE eos_variables, ONLY: nc, ncomp, uij, parame, mseg, sig_ij, rho, eta, x, t
6836  USE eos_constants, ONLY: dqp2, dqp3, dqp4
6837  IMPLICIT NONE
6838 !
6839 ! ----------------------------------------------------------------------
6840  REAL, INTENT(IN OUT) :: fdq
6841 ! ----------------------------------------------------------------------
6842  INTEGER :: i, j, k, m
6843  REAL :: factor2, factor3
6844  REAL :: xijfa, xijkfa, eij
6845  REAL :: fdq2, fdq3
6846  REAL, DIMENSION(nc) :: my2dd, myfac, qq2, q_fac
6847  REAL, DIMENSION(nc,nc) :: idq2, idq4
6848  REAL, DIMENSION(nc,nc,nc) :: idq3
6849 ! ----------------------------------------------------------------------
6850 
6851 
6852  fdq = 0.0
6853  DO i = 1, ncomp
6854  my2dd(i) = (parame(i,6))**2 *1.e-49 /(uij(i,i)*kbol* mseg(i)*sig_ij(i,i)**3 *1.e-30)
6855  myfac(i) = parame(i,3)/t*parame(i,2)**4 *my2dd(i)
6856  ! myfac(i)=parame(i,3)/T*parame(i,2)**4 *my2dd_renormalized(i)
6857  qq2(i) = (parame(i,7))**2 *1.e-69 / (uij(i,i)*kbol*mseg(i)*sig_ij(i,i)**5 *1.e-50)
6858  q_fac(i) = parame(i,3)/t*parame(i,2)**4 *qq2(i)
6859  END DO
6860 
6861  DO i = 1, ncomp
6862  DO j = 1, ncomp
6863  idq2(i,j) = 0.0
6864  idq4(i,j) = 0.0
6865  IF (myfac(i) /= 0.0 .AND. q_fac(j) /= 0.0) THEN
6866  DO m = 0, 4
6867  idq2(i,j) = idq2(i,j) + dqp2(i,j,m)*eta**m
6868  idq4(i,j) = idq4(i,j) + dqp4(i,j,m)*eta**m
6869  END DO
6870  DO k = 1, ncomp
6871  idq3(i,j,k) = 0.0
6872  IF (myfac(k) /= 0.0 .OR. q_fac(k) /= 0.0) THEN
6873  DO m = 0, 4
6874  idq3(i,j,k) = idq3(i,j,k) + dqp3(i,j,k,m)*eta**m
6875  END DO
6876  END IF
6877  END DO
6878  END IF
6879  END DO
6880  END DO
6881 
6882  factor2 = -9.0/4.0 * pi *rho
6883  factor3 = pi**2 * rho**2
6884 
6885  fdq2 = 0.0
6886  fdq3 = 0.0
6887  DO i = 1, ncomp
6888  DO j = 1, ncomp
6889  IF (myfac(i) /= 0.0 .AND. q_fac(j) /= 0.0) THEN
6890  xijfa = x(i)*myfac(i) * x(j)*q_fac(j) /sig_ij(i,j)**5
6891  eij = (parame(i,3)*parame(j,3))**0.5
6892  fdq2 = fdq2 +factor2* xijfa*(idq2(i,j)+eij/t*idq4(i,j))
6893  DO k = 1, ncomp
6894  IF (myfac(k) /= 0.0 .OR. q_fac(k) /= 0.0) THEN
6895  xijkfa=x(i)*x(j)*x(k)/(sig_ij(i,j)*sig_ij(i,k)*sig_ij(j,k))**2 &
6896  *( myfac(i)*q_fac(j)*myfac(k) + myfac(i)*q_fac(j)*q_fac(k)*1.1937350 )
6897  fdq3 = fdq3 + factor3*xijkfa*idq3(i,j,k)
6898  END IF
6899  END DO
6900  END IF
6901  END DO
6902  END DO
6903 
6904  IF (fdq2 < -1.e-50 .AND. fdq3 /= 0.0) THEN
6905  fdq = fdq2 / ( 1.0 - fdq3/fdq2 )
6906  END IF
6907 
6908 END SUBROUTINE f_dq_vrabec_gross
6909 
6910 
6911 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6912 !
6913 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
6914 !
6915  SUBROUTINE f_dft ( I1_dft, I2_dft )
6916 !
6917  USE eos_variables, ONLY: nc, pi, ncomp, t, rho, eta, x, mseg, parame
6918  USE dft_module
6919  IMPLICIT NONE
6920 !
6921 ! ----------------------------------------------------------------------
6922  REAL, INTENT(OUT) :: i1_dft
6923  REAL, INTENT(OUT) :: i2_dft
6924 !
6925 ! ----------------------------------------------------------------------
6926  INTEGER :: k,ih
6927  ! REAL :: z3
6928  REAL :: ua, ua_c, ua_2, ua_c_2, rm
6929  REAL :: int10, int11, int20, int21
6930  REAL :: dg_drho
6931  REAL :: rad, xg, rdf, rho_st, msegm
6932  REAL :: sig_ij
6933  REAL :: dg_dr, dzr_org !,rdf_d
6934  ! REAL :: intgrid(0:NDFT),intgri2(0:NDFT)
6935 ! ----------------------------------------------------------------------
6936 
6937 ! -----constants--------------------------------------------------------
6938 msegm = parame(1,1)
6939 rho_st = rho * parame(1,2)**3
6940 
6941 ua_c = 4.0 * ( rc**(-12) - rc**(-6) )
6942 ua_c_2 = ua_c * ua_c
6943 rm = 2.0**(1.0/6.0)
6944 
6945 int10 = rc*rc* ua_c
6946 int20 = rc*rc* ua_c_2
6947 ! intgrid(0)= int10
6948 ! intgri2(0)= int20
6949 
6950 
6951 sig_ij = parame(1,2)
6952 
6953 
6954 i1_dft = 0.0
6955 i2_dft = 0.0
6956 rad = rc
6957 !dzr = dzp / 2.0 ! this line is obsolete. dzr is defined in DFT-nMF2 (dimensionless)
6958 dzr_org= dzr
6959 k = 0
6960 ih = 85
6961 
6962 DO WHILE ( rad-dzr+1.e-9 >= 1.0 )
6963 
6964  rad = rad - dzr
6965  ! IF (rad <= 8.0) dzr = dzp
6966  ! IF (rad <= rg) dzr = dzp/2.0
6967  k = k + 1
6968  xg = rad / dhs_st
6969  ua = 4.0 * ( rad**(-12) - rad**(-6) )
6970  ua_2 = ua * ua
6971  rdf = 1.0
6972  dg_drho = 0.0
6973  IF ( rad <= rg ) THEN
6974  CALL bi_cub_spline (rho_st,xg,ya,x1a,x2a,y1a,y2a,y12a, &
6975  c_bicub,rdf,dg_drho,dg_dr,den_step,ih,k)
6976  END IF
6977 
6978  int11 = rdf*rad*rad* ua
6979  int21 = rdf*rad*rad* ua_2
6980  i1_dft= i1_dft + dzr*(int11+int10)/2.0
6981  i2_dft= i2_dft + dzr*(int21+int20)/2.0
6982  int10 = int11
6983  int20 = int21
6984 
6985 END DO
6986 
6987 dzr = dzr_org
6988 
6989 ! stepno = k
6990 ! CALL SPLINE_PARA (dzr,intgrid,utri,stepno)
6991 ! CALL SPLINE_INT (I1,dzr,intgrid,utri,stepno)
6992 
6993 ! caution: 1st order integral is in F_EOS.f defined with negative sign
6994 i1_dft= - i1_dft - ( 4.0/9.0 * rc**(-9) - 4.0/3.0 * rc**(-3) )
6995 
6996 ! CALL SPLINE_PARA (dzr,intgri2,utri,stepno)
6997 ! CALL SPLINE_INT (I2,dzr,intgri2,utri,stepno)
6998 
6999 i2_dft = i2_dft + 16.0/21.0 * rc**(-21) - 32.0/15.0 * rc**(-15) + 16.0/9.0 * rc**(-9)
7000 
7001 
7002 END SUBROUTINE f_dft
7003 
7004 
7005 
7006 
7007 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
7008 !
7009 !WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
7010 !
7011  REAL FUNCTION tangent_value2 ( optpara, n )
7012 ! SUBROUTINE TANGENT_VALUE ( fmin, optpara, n )
7013 !
7014  USE basic_variables
7015  USE starting_values
7016  IMPLICIT NONE
7017 !
7018 ! ----------------------------------------------------------------------
7019  INTEGER, INTENT(IN) :: n
7020  REAL, INTENT(IN) :: optpara(n)
7021  !REAL, INTENT(IN) :: optpara(:)
7022  !REAL, INTENT(IN OUT) :: fmin
7023 !
7024 ! ----------------------------------------------------------------------
7025  INTEGER :: i
7026  REAL :: lnphi(np,nc),ph_frac, gibbs_full(np),xlnx1,xlnx2
7027  REAL, DIMENSION(nc) :: ni_1, ni_2
7028 ! ----------------------------------------------------------------------
7029 
7030 
7031  ! --- setting of mole fractions ---------------------------------------
7032  DO i = 1, ncomp
7033  IF ( optpara(i) < -300.0 ) THEN
7034  ni_2(i) = 0.0
7035  ELSE
7036  ni_2(i) = exp( optpara(i) )
7037  END IF
7038  END DO
7039 
7040  DO i = 1, ncomp
7041  ni_1(i) = xif(i) - ni_2(i)
7042  IF ( ni_2(i) > xif(i) ) THEN
7043  ni_2(i) = xif(i)
7044  ni_1(i) = xif(i) * 1.e-20
7045  ENDIF
7046  END DO
7047 
7048  xi(2,1:ncomp) = ni_2(1:ncomp) / sum( ni_2(1:ncomp) )
7049  lnx(2,1:ncomp) = optpara(1:ncomp) - log( sum( ni_2(1:ncomp) ) )
7050 
7051  ph_frac = sum( ni_1(1:ncomp) )
7052  xi(1,1:ncomp) = ni_1(1:ncomp) / ph_frac
7053  lnx(1,1:ncomp) = log( ni_1(1:ncomp) ) - log( ph_frac )
7054  ! write (*,'(a,4G18.8)') 'FF',(xif(i),i=1,ncomp)
7055  ! write (*,'(a,4G18.8)') 'AA',(xi(1,i),i=1,ncomp)
7056  ! write (*,'(a,3G18.8)') 'BB',(xi(2,i),i=1,ncomp)
7057 
7058  CALL fugacity (lnphi)
7059  !CALL enthalpy_etc
7060 
7061  gibbs(1) = sum( xi(1,1:ncomp) * lnphi(1,1:ncomp) ) ! dimensionless g/RT
7062  gibbs(2) = sum( xi(2,1:ncomp) * lnphi(2,1:ncomp) )
7063 
7064  xlnx1 = sum( xi(1,1:ncomp)*lnx(1,1:ncomp) ) ! dimensionless s/RT
7065  xlnx2 = sum( xi(2,1:ncomp)*lnx(2,1:ncomp) )
7066 
7067  gibbs_full(1) = gibbs(1) + xlnx1
7068  gibbs_full(2) = gibbs(2) + xlnx2
7069 
7070  tangent_value2 = gibbs_full(1)*ph_frac + gibbs_full(2)*(1.0-ph_frac)
7071  !fmin = gibbs_full(1)*ph_frac + gibbs_full(2)*(1.0-ph_frac)
7072  !write (*,'(a,4G18.8)') 'TP',TANGENT_VALUE2,(lnx(1,i),i=1,ncomp)
7073  !write (*,'(a,4G18.8)') 'al',ph_frac,(lnx(2,i), i=1,ncomp)
7074  !write (*,*) ' '
7075  !pause
7076 
7077 END FUNCTION tangent_value2
7078 
7079 
7080 
7081 
7082 
7083 
7084 
7085 
parameters
WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW This module contains constant...
Definition: modules.f90:6
lambda
double lambda
Latent heat of blowing agent, J/kg.
Definition: experimentalInputs.h:118
eos_constants
WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW This module contains paramete...
Definition: modules.f90:200
dft_module
WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW Module DFT_MODULE This module...
Definition: modules.f90:272
eos_variables
WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW This module contains paramete...
Definition: modules.f90:120
starting_values
WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW Module STARTING_VALUES This m...
Definition: modules.f90:251
basic_variables
WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW This module contains paramete...
Definition: modules.f90:29
eos_numerical_derivatives
WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW This module contains paramete...
Definition: modules.f90:220