| | 594 | |
| | 595 | |
| | 596 | #if HAVE_LAPACK == yes |
| | 597 | #include <stdlib.h> /*+ For malloc and free +*/ |
| | 598 | #include <stdio.h> /*+ For printf +*/ |
| | 599 | void dgetrf_ (int *, int *, double *, int *, int *, int *); |
| | 600 | void dlaswp_ (int *, double *, int *, int *, int *, int *, int *); |
| | 601 | void dtrsm_ (char *, char *, char *, char *, int *, int *, double *, |
| | 602 | double *, int *, double *, int *); |
| | 603 | |
| | 604 | /*++++++++++++++++++++++++++++++++++++++ |
| | 605 | Adjust the Gaussian energy parameters (G) such that on return, the free |
| | 606 | energy at each Gaussian concentration is equal to the incoming value of G0. |
| | 607 | |
| | 608 | int adjust_gaussians Retunrs 0 or an error code. |
| | 609 | |
| | 610 | double T Temperature. |
| | 611 | |
| | 612 | double P Pressure (ignored for now). |
| | 613 | |
| | 614 | double *G0 Intended free energy values at Gaussian center compositions. |
| | 615 | |
| | 616 | energy_params *eparams Free energy function parameters. |
| | 617 | |
| | 618 | int efunc Index indicating which set of energy parameters to use |
| | 619 | ++++++++++++++++++++++++++++++++++++++*/ |
| | 620 | |
| | 621 | int adjust_gaussians |
| | 622 | (double T, double P, double *G0, energy_params *eparams, int efunc) |
| | 623 | { |
| | 624 | double *G_scratch, *G_matrix, one=1.; |
| | 625 | int i,j, gs = eparams [efunc].n_gauss, piv[gs]; |
| | 626 | |
| | 627 | // Do one malloc for both arrays |
| | 628 | if (!(G_scratch = malloc (gs*(gs+1) * sizeof (double)))) |
| | 629 | return 1; |
| | 630 | G_matrix = G_scratch + gs; |
| | 631 | |
| | 632 | // Calculate the free energy at each point without any Gaussians. |
| | 633 | for (i=0; i<gs; i++) |
| | 634 | (eparams[efunc].gauss)[i].G = 0.; |
| | 635 | for (i=0; i<gs; i++) |
| | 636 | G_scratch [i] = free_energy |
| | 637 | ((eparams[efunc].gauss)[i].C2, (eparams[efunc].gauss)[i].C3, T, P, |
| | 638 | eparams+efunc); |
| | 639 | |
| | 640 | // Calculate the effect of each Gaussian on the energy at all of the other |
| | 641 | // points. |
| | 642 | for (i=0; i<gs; i++) |
| | 643 | { |
| | 644 | (eparams[efunc].gauss)[i].G = 1.; |
| | 645 | for (j=0; j<gs; j++) |
| | 646 | G_matrix [i*gs+j] = free_energy |
| | 647 | ((eparams[efunc].gauss)[j].C2, (eparams[efunc].gauss)[j].C3, T, P, |
| | 648 | eparams+efunc) - G_scratch [j]; |
| | 649 | (eparams[efunc].gauss)[i].G = 0.; |
| | 650 | } |
| | 651 | |
| | 652 | // Set G_scratch values to G0 for solving below |
| | 653 | for (i=0; i<gs; i++) |
| | 654 | G_scratch [i] = G0 [i] - G_scratch [i]; |
| | 655 | |
| | 656 | // Solve for the new G values values using LAPACK |
| | 657 | dgetrf_ (&gs, &gs, G_matrix, &gs, piv, &i); |
| | 658 | if (i != 0) |
| | 659 | return i; |
| | 660 | i=1; |
| | 661 | dlaswp_ (&i, G_scratch, &gs, &i, &gs, piv, &i); |
| | 662 | dtrsm_("Left", "Lower", "No transpose", "Unit", &gs, &i, &one, G_matrix, &gs, |
| | 663 | G_scratch, &gs); |
| | 664 | dtrsm_("Left", "Upper", "No transpose", "Non-Unit", &gs, &i, &one, G_matrix, |
| | 665 | &gs, G_scratch, &gs); |
| | 666 | |
| | 667 | // Put them into the Gaussian structures |
| | 668 | for (i=0; i<gs; i++) |
| | 669 | (eparams[efunc].gauss)[i].G = G_scratch [i]; |
| | 670 | |
| | 671 | #ifdef DEBUG |
| | 672 | // Test the results |
| | 673 | for (i=0; i<gs; i++) |
| | 674 | printf ("Point %d at %g,%g: G=%g, energy=%g, G0=%g\n", i, |
| | 675 | (eparams[efunc].gauss)[i].C2, (eparams[efunc].gauss)[i].C3, |
| | 676 | (eparams[efunc].gauss)[i].G, |
| | 677 | free_energy ((eparams[efunc].gauss)[i].C2, |
| | 678 | (eparams[efunc].gauss)[i].C3, T, P, eparams+efunc), |
| | 679 | G0 [i]); |
| | 680 | #endif |
| | 681 | |
| | 682 | // Clean up and go home |
| | 683 | free(G_scratch); |
| | 684 | return 0; |
| | 685 | } |
| | 686 | #endif |